mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/7/13
   7 ;;      Renamed: 1994/8/31 from tm-body.el
   8 ;;      Renamed: 1997/02/19 from tm-view.el
   9 ;; Version: $Revision: 0.33 $
  10 ;; Keywords: MIME, multimedia, mail, news
  11
  12 ;; This file is part of SEMI (SEMI is Emacs MIME Interfaces).
  13
  14 ;; This program is free software; you can redistribute it and/or
  15 ;; modify it under the terms of the GNU General Public License as
  16 ;; published by the Free Software Foundation; either version 2, or (at
  17 ;; your option) any later version.
  18
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 ;; General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Code:
  30
  31 (require 'cl)
  32 (require 'std11)
  33 (require 'mel)
  34 (require 'eword-decode)
  35 (require 'mime-parse)
  36 (require 'mime-text)
  37
  38
  39 ;;; @ version
  40 ;;;
  41
  42 (defconst mime-view-RCS-ID
  43   "$Id: mime-view.el,v 0.33 1997-03-17 11:52:19 morioka Exp $")
  44
  45 (defconst mime-view-version (get-version-string mime-view-RCS-ID))
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defvar mime/content-decoding-condition
  52   '(((type . "text/plain")
  53      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
  54      (mode "play" "print")
  55      )
  56     ((type . "text/html")
  57      (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
  58      (mode . "play")
  59      )
  60     ((type . "text/x-rot13-47")
  61      (method . mime-article/decode-caesar)
  62      (mode . "play")
  63      )
  64     ((type . "audio/basic")
  65      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name)
  66      (mode . "play")
  67      )
  68
  69     ((type . "image/jpeg")
  70      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  71      (mode "play" "print")
  72      )
  73     ((type . "image/gif")
  74      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  75      (mode "play" "print")
  76      )
  77     ((type . "image/tiff")
  78      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  79      (mode "play" "print")
  80      )
  81     ((type . "image/x-tiff")
  82      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  83      (mode "play" "print")
  84      )
  85     ((type . "image/x-xbm")
  86      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  87      (mode "play" "print")
  88      )
  89     ((type . "image/x-pic")
  90      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  91      (mode "play" "print")
  92      )
  93     ((type . "image/x-mag")
  94      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  95      (mode "play" "print")
  96      )
  97
  98     ((type . "video/mpeg")
  99      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name)
 100      (mode . "play")
 101      )
 102
 103     ((type . "application/postscript")
 104      (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
 105      (mode "play" "print")
 106      )
 107     ((type . "application/octet-stream")
 108      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 109      (mode "play" "print")
 110      )
 111
 112     ;;((type . "message/external-body")
 113     ;; (method "xterm" nil
 114     ;;         "-e" "showexternal"
 115     ;;         'file '"access-type" '"name" '"site" '"directory"))
 116     ((type . "message/rfc822")
 117      (method . mime-article/view-message/rfc822)
 118      (mode . "play")
 119      )
 120     ((type . "message/partial")
 121      (method . mime-article/decode-message/partial)
 122      (mode . "play")
 123      )
 124     ((type . "message/external-body")
 125      ("access-type" . "anon-ftp")
 126      (method . mime-article/decode-message/external-ftp)
 127      )
 128
 129     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
 130      (mode . "play")
 131      )
 132     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
 133      (mode . "extract")
 134      )
 135     ))
 136
 137 (defvar mime-view-childrens-header-showing-Content-Type-list
 138   '("message/rfc822" "message/news"))
 139
 140 (defvar mime-view-visible-media-type-list
 141   '("text/plain" nil "text/richtext" "text/enriched"
 142     "text/rfc822-headers"
 143     "text/x-latex" "application/x-latex"
 144     "message/delivery-status"
 145     "application/pgp" "text/x-pgp"
 146     "application/octet-stream"
 147     "application/x-selection" "application/x-comment")
 148   "*List of media-types to be able to display in MIME-View buffer.
 149 Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".")
 150
 151 (defvar mime-view-content-button-ignored-ctype-list
 152   '("application/x-selection"))
 153
 154 (defvar mime-view-content-button-visible-ctype-list
 155   '("application/pgp"))
 156
 157 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 158
 159 (defvar mime-view-ignored-field-list
 160   '(".*Received" ".*Path" ".*Id" "References"
 161     "Replied" "Errors-To"
 162     "Lines" "Sender" ".*Host" "Xref"
 163     "Content-Type" "Precedence"
 164     "Status" "X-VM-.*")
 165   "All fields that match this list will be hidden in MIME preview buffer.
 166 Each elements are regexp of field-name. [mime-view.el]")
 167
 168 (defvar mime-view-ignored-field-regexp
 169   (concat "^"
 170           (apply (function regexp-or) mime-view-ignored-field-list)
 171           ":"))
 172
 173 (defvar mime-view-visible-field-list
 174   '("Dnas.*" "Message-Id")
 175   "All fields that match this list will be displayed in MIME preview buffer.
 176 Each elements are regexp of field-name. [mime-view.el]")
 177
 178 (defvar mime-view-visible-field-regexp
 179   (concat "^"
 180           (apply (function regexp-or) mime-view-visible-field-list)
 181           ":"))
 182
 183 (defvar mime-view-redisplay nil)
 184
 185 (defvar mime-view-announcement-for-message/partial
 186   (if (and (>= emacs-major-version 19) window-system)
 187       "\
 188 \[[ This is message/partial style split message. ]]
 189 \[[ Please press `v' key in this buffer          ]]
 190 \[[ or click here by mouse button-2.             ]]"
 191     "\
 192 \[[ This is message/partial style split message. ]]
 193 \[[ Please press `v' key in this buffer.         ]]"
 194     ))
 195
 196
 197 ;;; @@ predicate functions
 198 ;;;
 199
 200 (defun mime-view-header-visible-p (rcnum cinfo &optional ctype)
 201   (or (null rcnum)
 202       (progn
 203         (setq ctype
 204               (mime::content-info/type
 205                (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)
 206                ))
 207         (member ctype mime-view-childrens-header-showing-Content-Type-list)
 208         )))
 209
 210 (defun mime-view-body-visible-p (rcnum cinfo &optional ctype)
 211   (let (ccinfo)
 212     (or ctype
 213         (setq ctype
 214               (mime::content-info/type
 215                (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 216                ))
 217         )
 218     (and (member ctype mime-view-visible-media-type-list)
 219          (if (string-equal ctype "application/octet-stream")
 220              (progn
 221                (or ccinfo
 222                    (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
 223                    )
 224                (member (mime::content-info/encoding ccinfo)
 225                        '(nil "7bit" "8bit"))
 226                )
 227            t))
 228     ))
 229
 230
 231 ;;; @@ content button
 232 ;;;
 233
 234 (defun mime-preview/insert-content-button
 235   (rcnum cinfo ctype params subj encoding)
 236   (save-restriction
 237     (narrow-to-region (point)(point))
 238     (let ((access-type (assoc "access-type" params))
 239           (charset (assoc "charset" params))
 240           (num (or (cdr (assoc "x-part-number" params))
 241                    (if (consp rcnum)
 242                        (mapconcat (function
 243                                    (lambda (num)
 244                                      (format "%s" (1+ num))
 245                                      ))
 246                                   (reverse rcnum) ".")
 247                      "0"))
 248                ))
 249       (cond (access-type
 250              (let ((server (assoc "server" params)))
 251                (setq access-type (cdr access-type))
 252                (if server
 253                    (insert (format "[%s %s ([%s] %s)]\n" num subj
 254                                    access-type (cdr server)))
 255                  (let ((site (cdr (assoc "site" params)))
 256                        (dir (cdr (assoc "directory" params)))
 257                        )
 258                    (insert (format "[%s %s ([%s] %s:%s)]\n" num subj
 259                                    access-type site dir))
 260                    )))
 261              )
 262             (t
 263              (insert (concat "[" num " " subj))
 264              (let ((rest
 265                     (if (setq charset (cdr charset))
 266                         (if encoding
 267                             (format " <%s; %s (%s)>]\n"
 268                                     ctype charset encoding)
 269                           (format " <%s; %s>]\n" ctype charset)
 270                           )
 271                       (format " <%s>]\n" ctype)
 272                       )))
 273                (if (>= (+ (current-column)(length rest))(window-width))
 274                    (setq rest (concat "\n\t" rest))
 275                  )
 276                (insert rest)
 277                ))))
 278     (mime-add-button (point-min)(1- (point-max))
 279                      (function mime-play-entity))
 280     ))
 281
 282 (defun mime-preview/default-content-button-function
 283   (rcnum cinfo ctype params subj encoding)
 284   (if (and (consp rcnum)
 285            (not (member
 286                  ctype
 287                  mime-view-content-button-ignored-ctype-list)))
 288       (mime-preview/insert-content-button
 289        rcnum cinfo ctype params subj encoding)
 290     ))
 291
 292 (defvar mime-preview/content-button-function
 293   (function mime-preview/default-content-button-function))
 294
 295
 296 ;;; @@ content header filter
 297 ;;;
 298
 299 (defun mime-preview/cut-header ()
 300   (goto-char (point-min))
 301   (while (and
 302           (re-search-forward mime-view-ignored-field-regexp nil t)
 303           (let* ((beg (match-beginning 0))
 304                  (end (match-end 0))
 305                  (name (buffer-substring beg end))
 306                  )
 307             (if (not (string-match mime-view-visible-field-regexp name))
 308                 (delete-region
 309                  beg
 310                  (save-excursion
 311                    (and
 312                     (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 313                     (match-beginning 0)
 314                     )))
 315               )
 316             t)))
 317   )
 318
 319 (defun mime-view-default-content-header-filter ()
 320   (mime-preview/cut-header)
 321   (eword-decode-header)
 322   )
 323
 324 (defvar mime-view-content-header-filter-alist nil)
 325
 326
 327 ;;; @@ content filter
 328 ;;;
 329
 330 (defvar mime-view-content-filter-alist
 331   '(("text/enriched" . mime-preview/filter-for-text/enriched)
 332     ("text/richtext" . mime-preview/filter-for-text/richtext)
 333     (t . mime-preview/filter-for-text/plain)
 334     ))
 335
 336
 337 ;;; @@ content separator
 338 ;;;
 339
 340 (defun mime-preview/default-content-separator (rcnum cinfo ctype params subj)
 341   (if (and (not (mime-view-header-visible-p rcnum cinfo ctype))
 342            (not (mime-view-body-visible-p rcnum cinfo ctype))
 343            )
 344       (progn
 345         (goto-char (point-max))
 346         (insert "\n")
 347         )))
 348
 349
 350 ;;; @@ buffer local variables
 351 ;;;
 352
 353 ;;; @@@ in raw buffer
 354 ;;;
 355
 356 (make-variable-buffer-local 'mime::article/content-info)
 357
 358 (defvar mime::article/preview-buffer nil)
 359 (make-variable-buffer-local 'mime::article/preview-buffer)
 360
 361
 362 ;;; @@@ in view buffer
 363 ;;;
 364
 365 (make-variable-buffer-local 'mime::preview/mother-buffer)
 366 (make-variable-buffer-local 'mime::preview/content-list)
 367
 368 (defvar mime::preview/article-buffer nil)
 369 (make-variable-buffer-local 'mime::preview/article-buffer)
 370
 371 (make-variable-buffer-local 'mime::preview/original-major-mode)
 372 (make-variable-buffer-local 'mime::preview/original-window-configuration)
 373
 374
 375 ;;; @@ quitting method
 376 ;;;
 377
 378 (defvar mime-view-quitting-method-alist
 379   '((mime/show-message-mode
 380      . mime-view-quitting-method-for-mime/show-message-mode)))
 381
 382 (defvar mime-view-over-to-previous-method-alist nil)
 383 (defvar mime-view-over-to-next-method-alist nil)
 384
 385 (defvar mime-view-show-summary-method nil)
 386
 387
 388 ;;; @@ following method
 389 ;;;
 390
 391 (defvar mime-view-following-method-alist nil)
 392
 393 (defvar mime-view-following-required-fields-list
 394   '("From"))
 395
 396
 397 ;;; @@ X-Face
 398 ;;;
 399
 400 ;; hack from Gnus 5.0.4.
 401
 402 (defvar mime-view-x-face-to-pbm-command
 403   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 404
 405 (defvar mime-view-x-face-command
 406   (concat mime-view-x-face-to-pbm-command
 407           " | xv -quit -")
 408   "String to be executed to display an X-Face field.
 409 The command will be executed in a sub-shell asynchronously.
 410 The compressed face will be piped to this command.")
 411
 412 (defun mime-view-x-face-function ()
 413   "Function to display X-Face field. You can redefine to customize."
 414   ;; 1995/10/12 (c.f. tm-eng:130)
 415   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 416   (save-restriction
 417     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 418     ;; end
 419     (goto-char (point-min))
 420     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 421         (let ((beg (match-end 0))
 422               (end (std11-field-end))
 423               )
 424           (call-process-region beg end "sh" nil 0 nil
 425                                "-c" mime-view-x-face-command)
 426           ))))
 427
 428
 429 ;;; @@ utility
 430 ;;;
 431
 432 (defun mime-preview/get-original-major-mode ()
 433   (if mime::preview/mother-buffer
 434       (save-excursion
 435         (set-buffer mime::preview/mother-buffer)
 436         (mime-preview/get-original-major-mode)
 437         )
 438     mime::preview/original-major-mode))
 439
 440
 441 ;;; @ data structures
 442 ;;;
 443
 444 ;;; @@ preview-content-info
 445 ;;;
 446
 447 (define-structure mime::preview-content-info
 448   point-min point-max buffer content-info)
 449
 450
 451 ;;; @ buffer setup
 452 ;;;
 453
 454 (defun mime-view-setup-buffer (&optional ctl encoding ibuf obuf)
 455   (if ibuf
 456       (progn
 457         (get-buffer ibuf)
 458         (set-buffer ibuf)
 459         ))
 460   (or mime-view-redisplay
 461       (setq mime::article/content-info (mime-parse-message ctl encoding))
 462       )
 463   (let ((ret (mime-view-make-preview-buffer obuf)))
 464     (setq mime::article/preview-buffer (car ret))
 465     ret))
 466
 467 (defun mime-view-make-preview-buffer (&optional obuf)
 468   (let* ((cinfo mime::article/content-info)
 469          (pcl (mime/flatten-content-info cinfo))
 470          (dest (make-list (length pcl) nil))
 471          (the-buf (current-buffer))
 472          (mode major-mode)
 473          )
 474     (or obuf
 475         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 476     (set-buffer (get-buffer-create obuf))
 477     (setq buffer-read-only nil)
 478     (widen)
 479     (erase-buffer)
 480     (setq mime::preview/article-buffer the-buf)
 481     (setq mime::preview/original-major-mode mode)
 482     (setq major-mode 'mime-view-mode)
 483     (setq mode-name "MIME-View")
 484     (let ((drest dest))
 485       (while pcl
 486         (setcar drest
 487                 (mime-preview/display-content (car pcl) cinfo the-buf obuf))
 488         (setq pcl (cdr pcl)
 489               drest (cdr drest))
 490         ))
 491     (set-buffer-modified-p nil)
 492     (setq buffer-read-only t)
 493     (set-buffer the-buf)
 494     (list obuf dest)
 495     ))
 496
 497 (defun mime-preview/display-content (content cinfo ibuf obuf)
 498   (let* ((beg (mime::content-info/point-min content))
 499          (end (mime::content-info/point-max content))
 500          (ctype (mime::content-info/type content))
 501          (params (mime::content-info/parameters content))
 502          (encoding (mime::content-info/encoding content))
 503          (rcnum (mime::content-info/rcnum content))
 504          he e nb ne subj)
 505     (set-buffer ibuf)
 506     (goto-char beg)
 507     (setq he (if (re-search-forward "^$" nil t)
 508                  (1+ (match-end 0))
 509                end))
 510     (if (> he end)
 511         (setq he end)
 512       )
 513     (save-restriction
 514       (narrow-to-region beg end)
 515       (setq subj
 516             (eword-decode-string
 517              (mime-article/get-subject params encoding)))
 518       )
 519     (set-buffer obuf)
 520     (setq nb (point))
 521     (narrow-to-region nb nb)
 522     (funcall mime-preview/content-button-function
 523              rcnum cinfo ctype params subj encoding)
 524     (if (mime-view-header-visible-p rcnum cinfo ctype)
 525         (mime-preview/display-header beg he)
 526       )
 527     (if (and (null rcnum)
 528              (member
 529               ctype mime-view-content-button-visible-ctype-list))
 530         (save-excursion
 531           (goto-char (point-max))
 532           (mime-preview/insert-content-button
 533            rcnum cinfo ctype params subj encoding)
 534           ))
 535     (cond ((mime-view-body-visible-p rcnum cinfo ctype)
 536            (mime-preview/display-body he end
 537                                       rcnum cinfo ctype params subj encoding)
 538            )
 539           ((equal ctype "message/partial")
 540            (mime-preview/display-message/partial)
 541            )
 542           ((and (null rcnum)
 543                 (null (mime::content-info/children cinfo))
 544                 )
 545            (goto-char (point-max))
 546            (mime-preview/insert-content-button
 547             rcnum cinfo ctype params subj encoding)
 548            ))
 549     (mime-preview/default-content-separator rcnum cinfo ctype params subj)
 550     (prog1
 551         (progn
 552           (setq ne (point-max))
 553           (widen)
 554           (mime::preview-content-info/create nb (1- ne) ibuf content)
 555           )
 556       (goto-char ne)
 557       )))
 558
 559 (defun mime-preview/display-header (beg end)
 560   (save-restriction
 561     (narrow-to-region (point)(point))
 562     (insert-buffer-substring mime::preview/article-buffer beg end)
 563     (let ((f (cdr (assq mime::preview/original-major-mode
 564                         mime-view-content-header-filter-alist))))
 565       (if (functionp f)
 566           (funcall f)
 567         (mime-view-default-content-header-filter)
 568         ))
 569     (run-hooks 'mime-view-content-header-filter-hook)
 570     ))
 571
 572 (defun mime-preview/display-body (beg end
 573                                       rcnum cinfo ctype params subj encoding)
 574   (save-restriction
 575     (narrow-to-region (point-max)(point-max))
 576     (insert-buffer-substring mime::preview/article-buffer beg end)
 577     (let ((f (cdr (or (assoc ctype mime-view-content-filter-alist)
 578                       (assq t mime-view-content-filter-alist)))))
 579       (and (functionp f)
 580            (funcall f ctype params encoding)
 581            )
 582       )))
 583
 584 (defun mime-preview/display-message/partial ()
 585   (save-restriction
 586     (goto-char (point-max))
 587     (if (not (search-backward "\n\n" nil t))
 588         (insert "\n")
 589       )
 590     (let ((be (point-max)))
 591       (narrow-to-region be be)
 592       (insert mime-view-announcement-for-message/partial)
 593       (mime-add-button (point-min)(point-max)
 594                        (function mime-play-entity))
 595       )))
 596
 597 (defun mime-article/get-uu-filename (param &optional encoding)
 598   (if (member (or encoding
 599                   (cdr (assq 'encoding param))
 600                   )
 601               mime-view-uuencode-encoding-name-list)
 602       (save-excursion
 603         (or (if (re-search-forward "^begin [0-9]+ " nil t)
 604                 (if (looking-at ".+$")
 605                     (buffer-substring (match-beginning 0)(match-end 0))
 606                   ))
 607             ""))
 608     ))
 609
 610 (defun mime-article/get-subject (param &optional encoding)
 611   (or (std11-find-field-body '("Content-Description" "Subject"))
 612       (let (ret)
 613         (if (or (and (setq ret (mime/Content-Disposition))
 614                      (setq ret (assoc "filename" (cdr ret)))
 615                      )
 616                 (setq ret (assoc "name" param))
 617                 (setq ret (assoc "x-name" param))
 618                 )
 619             (std11-strip-quoted-string (cdr ret))
 620           ))
 621       (mime-article/get-uu-filename param encoding)
 622       ""))
 623
 624
 625 ;;; @ content information
 626 ;;;
 627
 628 (defun mime-article/point-content-number (p &optional cinfo)
 629   (or cinfo
 630       (setq cinfo mime::article/content-info)
 631       )
 632   (let ((b (mime::content-info/point-min cinfo))
 633         (e (mime::content-info/point-max cinfo))
 634         (c (mime::content-info/children cinfo))
 635         )
 636     (if (and (<= b p)(<= p e))
 637         (or (let (co ret (sn 0))
 638               (catch 'tag
 639                 (while c
 640                   (setq co (car c))
 641                   (setq ret (mime-article/point-content-number p co))
 642                   (cond ((eq ret t) (throw 'tag (list sn)))
 643                         (ret (throw 'tag (cons sn ret)))
 644                         )
 645                   (setq c (cdr c))
 646                   (setq sn (1+ sn))
 647                   )))
 648             t))))
 649
 650 (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
 651   (or cinfo
 652       (setq cinfo mime::article/content-info)
 653       )
 654   (find-if (function
 655             (lambda (ci)
 656               (equal (mime::content-info/rcnum ci) rcnum)
 657               ))
 658            (mime/flatten-content-info cinfo)
 659            ))
 660
 661 (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
 662   (or cinfo
 663       (setq cinfo mime::article/content-info)
 664       )
 665   (if (eq cn t)
 666       cinfo
 667     (let ((sn (car cn)))
 668       (if (null sn)
 669           cinfo
 670         (let ((rc (nth sn (mime::content-info/children cinfo))))
 671           (if rc
 672               (mime-article/cnum-to-cinfo (cdr cn) rc)
 673             ))
 674         ))))
 675
 676 (defun mime/flatten-content-info (&optional cinfo)
 677   (or cinfo
 678       (setq cinfo mime::article/content-info)
 679       )
 680   (let ((dest (list cinfo))
 681         (rcl (mime::content-info/children cinfo))
 682         )
 683     (while rcl
 684       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
 685       (setq rcl (cdr rcl))
 686       )
 687     dest))
 688
 689 (defun mime-preview/point-pcinfo (p &optional pcl)
 690   (or pcl
 691       (setq pcl mime::preview/content-list)
 692       )
 693   (catch 'tag
 694     (let ((r pcl) cell)
 695       (while r
 696         (setq cell (car r))
 697         (if (and (<= (mime::preview-content-info/point-min cell) p)
 698                  (<= p (mime::preview-content-info/point-max cell))
 699                  )
 700             (throw 'tag cell)
 701           )
 702         (setq r (cdr r))
 703         ))
 704     (car (last pcl))
 705     ))
 706
 707
 708 ;;; @ MIME viewer mode
 709 ;;;
 710
 711 (defconst mime-view-menu-title "MIME-View")
 712 (defconst mime-view-menu-list
 713   '((up          "Move to upper content"      mime-view-up-content)
 714     (previous    "Move to previous content"   mime-view-previous-content)
 715     (next        "Move to next content"       mime-view-next-content)
 716     (scroll-down "Scroll to previous content" mime-view-scroll-down-content)
 717     (scroll-up   "Scroll to next content"     mime-view-scroll-up-content)
 718     (play        "Play Content"               mime-play-entity)
 719     (extract     "Extract Content"            mime-extract-entity)
 720     (print       "Print"                      mime-print-entity)
 721     (x-face      "Show X Face"                mime-view-display-x-face)
 722     )
 723   "Menu for MIME Viewer")
 724
 725 (cond (running-xemacs
 726        (defvar mime-view-xemacs-popup-menu
 727          (cons mime-view-menu-title
 728                (mapcar (function
 729                         (lambda (item)
 730                           (vector (nth 1 item)(nth 2 item) t)
 731                           ))
 732                        mime-view-menu-list)))
 733        (defun mime-view-xemacs-popup-menu (event)
 734          "Popup the menu in the MIME Viewer buffer"
 735          (interactive "e")
 736          (select-window (event-window event))
 737          (set-buffer (event-buffer event))
 738          (popup-menu 'mime-view-xemacs-popup-menu))
 739        (defvar mouse-button-2 'button2)
 740        )
 741       (t
 742        (defvar mouse-button-2 [mouse-2])
 743        ))
 744
 745 (defun mime-view-define-keymap (&optional default)
 746   (let ((mime-view-mode-map (if (keymapp default)
 747                                 (copy-keymap default)
 748                               (make-sparse-keymap)
 749                               )))
 750     (define-key mime-view-mode-map
 751       "u"        (function mime-view-up-content))
 752     (define-key mime-view-mode-map
 753       "p"        (function mime-view-previous-content))
 754     (define-key mime-view-mode-map
 755       "n"        (function mime-view-next-content))
 756     (define-key mime-view-mode-map
 757       "\e\t"     (function mime-view-previous-content))
 758     (define-key mime-view-mode-map
 759       "\t"       (function mime-view-next-content))
 760     (define-key mime-view-mode-map
 761       " "        (function mime-view-scroll-up-content))
 762     (define-key mime-view-mode-map
 763       "\M- "     (function mime-view-scroll-down-content))
 764     (define-key mime-view-mode-map
 765       "\177"     (function mime-view-scroll-down-content))
 766     (define-key mime-view-mode-map
 767       "\C-m"     (function mime-view-next-line-content))
 768     (define-key mime-view-mode-map
 769       "\C-\M-m"  (function mime-view-previous-line-content))
 770     (define-key mime-view-mode-map
 771       "v"        (function mime-play-entity))
 772     (define-key mime-view-mode-map
 773       "e"        (function mime-extract-entity))
 774     (define-key mime-view-mode-map
 775       "\C-c\C-p" (function mime-print-entity))
 776     (define-key mime-view-mode-map
 777       "a"        (function mime-view-follow-content))
 778     (define-key mime-view-mode-map
 779       "q"        (function mime-view-quit))
 780     (define-key mime-view-mode-map
 781       "h"        (function mime-view-show-summary))
 782     (define-key mime-view-mode-map
 783       "\C-c\C-x" (function mime-view-kill-buffer))
 784     (define-key mime-view-mode-map
 785       "<"        (function beginning-of-buffer))
 786     (define-key mime-view-mode-map
 787       ">"        (function end-of-buffer))
 788     (define-key mime-view-mode-map
 789       "?"        (function describe-mode))
 790     (if (functionp default)
 791         (setq mime-view-mode-map
 792               (append mime-view-mode-map (list (cons t default)))
 793               ))
 794     (if mouse-button-2
 795         (define-key mime-view-mode-map
 796           mouse-button-2 (function mime-button-dispatcher))
 797       )
 798     (cond (running-xemacs
 799            (define-key mime-view-mode-map
 800              mouse-button-3 (function mime-view-xemacs-popup-menu))
 801            )
 802           ((>= emacs-major-version 19)
 803            (define-key mime-view-mode-map [menu-bar mime-view]
 804              (cons mime-view-menu-title
 805                    (make-sparse-keymap mime-view-menu-title)))
 806            (mapcar (function
 807                     (lambda (item)
 808                       (define-key mime-view-mode-map
 809                         (vector 'menu-bar 'mime-view (car item))
 810                         (cons (nth 1 item)(nth 2 item))
 811                         )
 812                       ))
 813                    (reverse mime-view-menu-list)
 814                    )
 815            ))
 816     (use-local-map mime-view-mode-map)
 817     (run-hooks 'mime-view-define-keymap-hook)
 818     ))
 819
 820 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
 821                                  default-keymap-or-function)
 822   "Major mode for viewing MIME message.
 823
 824 Here is a list of the standard keys for mime-view-mode.
 825
 826 key             feature
 827 ---             -------
 828
 829 u               Move to upper content
 830 p or M-TAB      Move to previous content
 831 n or TAB        Move to next content
 832 SPC             Scroll up or move to next content
 833 M-SPC or DEL    Scroll down or move to previous content
 834 RET             Move to next line
 835 M-RET           Move to previous line
 836 v               Decode current content as `play mode'
 837 e               Decode current content as `extract mode'
 838 C-c C-p         Decode current content as `print mode'
 839 a               Followup to current content.
 840 x               Display X-Face
 841 q               Quit
 842 button-2        Move to point under the mouse cursor
 843                 and decode current content as `play mode'
 844 "
 845   (interactive)
 846   (let ((buf (get-buffer mime/output-buffer-name)))
 847     (if buf
 848         (save-excursion
 849           (set-buffer buf)
 850           (erase-buffer)
 851           )))
 852   (let ((ret (mime-view-setup-buffer ctl encoding ibuf obuf))
 853         (win-conf (current-window-configuration))
 854         )
 855     (prog1
 856         (switch-to-buffer (car ret))
 857       (setq mime::preview/original-window-configuration win-conf)
 858       (if mother
 859           (progn
 860             (setq mime::preview/mother-buffer mother)
 861             ))
 862       (mime-view-define-keymap default-keymap-or-function)
 863       (setq mime::preview/content-list (nth 1 ret))
 864       (goto-char
 865        (let ((ce (mime::preview-content-info/point-max
 866                   (car mime::preview/content-list)
 867                   ))
 868              e)
 869          (goto-char (point-min))
 870          (search-forward "\n\n" nil t)
 871          (setq e (match-end 0))
 872          (if (<= e ce)
 873              e
 874            ce)))
 875       (run-hooks 'mime-view-mode-hook)
 876       )))
 877
 878 (defun mime-preview/point-content-number (point)
 879   (save-window-excursion
 880     (let ((pc (mime-preview/point-pcinfo (point)))
 881           cinfo)
 882       (switch-to-buffer (mime::preview-content-info/buffer pc))
 883       (setq cinfo (mime::preview-content-info/content-info pc))
 884       (mime-article/point-content-number (mime::content-info/point-min cinfo))
 885       )))
 886
 887 (defun mime-preview/cinfo-to-pcinfo (cinfo)
 888   (let ((rpcl mime::preview/content-list) cell)
 889     (catch 'tag
 890       (while rpcl
 891         (setq cell (car rpcl))
 892         (if (eq cinfo (mime::preview-content-info/content-info cell))
 893             (throw 'tag cell)
 894           )
 895         (setq rpcl (cdr rpcl))
 896         ))))
 897
 898 (autoload 'mime-play-entity "mime-play")
 899
 900 (defun mime-extract-entity ()
 901   (interactive)
 902   (mime-play-entity "extract")
 903   )
 904
 905 (defun mime-print-entity ()
 906   (interactive)
 907   (mime-play-entity "print")
 908   )
 909
 910 (defun mime-view-follow-content ()
 911   (interactive)
 912   (let ((root-cinfo
 913          (mime::preview-content-info/content-info
 914           (car mime::preview/content-list)))
 915         pc p-beg p-end cinfo rcnum)
 916     (let ((rest mime::preview/content-list)
 917           b e cell len rc)
 918       (if (catch 'tag
 919             (while (setq cell (car rest))
 920               (setq b (mime::preview-content-info/point-min cell)
 921                     e (mime::preview-content-info/point-max cell))
 922               (setq rest (cdr rest))
 923               (if (and (<= b (point))(<= (point) e))
 924                   (throw 'tag cell)
 925                 )
 926               ))
 927           (progn
 928             (setq pc cell
 929                   cinfo (mime::preview-content-info/content-info pc)
 930                   rcnum (mime::content-info/rcnum cinfo))
 931             (setq len (length rcnum))
 932             (setq p-beg (mime::preview-content-info/point-min pc)
 933                   p-end (mime::preview-content-info/point-max pc))
 934             (while (and (setq cell (car rest))
 935                         (progn
 936                           (setq rc
 937                                 (mime::content-info/rcnum
 938                                  (mime::preview-content-info/content-info
 939                                   cell)))
 940                           (equal rcnum
 941                                  (nthcdr (- (length rc) len) rc))
 942                           ))
 943               (setq p-end (mime::preview-content-info/point-max cell))
 944               (setq rest (cdr rest))
 945               ))))
 946     (if pc
 947         (let* ((mode (mime-preview/get-original-major-mode))
 948                (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
 949                new-buf
 950                (the-buf (current-buffer))
 951                (a-buf mime::preview/article-buffer)
 952                fields)
 953           (save-excursion
 954             (set-buffer (setq new-buf (get-buffer-create new-name)))
 955             (erase-buffer)
 956             (insert-buffer-substring the-buf p-beg p-end)
 957             (goto-char (point-min))
 958             (if (mime-view-header-visible-p rcnum root-cinfo)
 959                 (delete-region (goto-char (point-min))
 960                                (if (re-search-forward "^$" nil t)
 961                                    (match-end 0)
 962                                  (point-min)))
 963               )
 964             (goto-char (point-min))
 965             (insert "\n")
 966             (goto-char (point-min))
 967             (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
 968               (while (progn
 969                        (setq str
 970                              (save-excursion
 971                                (set-buffer a-buf)
 972                                (setq ci (mime-article/rcnum-to-cinfo rcnum))
 973                                (save-restriction
 974                                  (narrow-to-region
 975                                   (mime::content-info/point-min ci)
 976                                   (mime::content-info/point-max ci)
 977                                   )
 978                                  (std11-header-string-except
 979                                   (concat "^"
 980                                           (apply (function regexp-or) fields)
 981                                           ":") ""))))
 982                        (if (string= (mime::content-info/type ci)
 983                                     "message/rfc822")
 984                            nil
 985                          (if str
 986                              (insert str)
 987                            )
 988                          rcnum))
 989                 (setq fields (std11-collect-field-names)
 990                       rcnum (cdr rcnum))
 991                 )
 992               )
 993             (let ((rest mime-view-following-required-fields-list))
 994               (while rest
 995                 (let ((field-name (car rest)))
 996                   (or (std11-field-body field-name)
 997                       (insert
 998                        (format
 999                         (concat field-name
1000                                 ": "
1001                                 (save-excursion
1002                                   (set-buffer the-buf)
1003                                   (set-buffer mime::preview/mother-buffer)
1004                                   (set-buffer mime::preview/article-buffer)
1005                                   (std11-field-body field-name)
1006                                   )
1007                                 "\n")))
1008                       ))
1009                 (setq rest (cdr rest))
1010                 ))
1011             (eword-decode-header)
1012             )
1013           (let ((f (cdr (assq mode mime-view-following-method-alist))))
1014             (if (functionp f)
1015                 (funcall f new-buf)
1016               (message
1017                (format
1018                 "Sorry, following method for %s is not implemented yet."
1019                 mode))
1020               ))
1021           ))))
1022
1023 (defun mime-view-display-x-face ()
1024   (interactive)
1025   (save-window-excursion
1026     (set-buffer mime::preview/article-buffer)
1027     (mime-view-x-face-function)
1028     ))
1029
1030 (defun mime-view-up-content ()
1031   (interactive)
1032   (let* ((pc (mime-preview/point-pcinfo (point)))
1033          (cinfo (mime::preview-content-info/content-info pc))
1034          (rcnum (mime::content-info/rcnum cinfo))
1035          )
1036     (if rcnum
1037         (let ((r (save-excursion
1038                    (set-buffer (mime::preview-content-info/buffer pc))
1039                    (mime-article/rcnum-to-cinfo (cdr rcnum))
1040                    ))
1041               (rpcl mime::preview/content-list)
1042               cell)
1043           (while (and
1044                   (setq cell (car rpcl))
1045                   (not (eq r (mime::preview-content-info/content-info cell)))
1046                   )
1047             (setq rpcl (cdr rpcl))
1048             )
1049           (goto-char (mime::preview-content-info/point-min cell))
1050           )
1051       (mime-view-quit)
1052       )))
1053
1054 (defun mime-view-previous-content ()
1055   (interactive)
1056   (let* ((pcl mime::preview/content-list)
1057          (p (point))
1058          (i (- (length pcl) 1))
1059          beg)
1060     (catch 'tag
1061       (while (> i 0)
1062         (setq beg (mime::preview-content-info/point-min (nth i pcl)))
1063         (if (> p beg)
1064             (throw 'tag (goto-char beg))
1065           )
1066         (setq i (- i 1))
1067         )
1068       (let ((f (assq mime::preview/original-major-mode
1069                      mime-view-over-to-previous-method-alist)))
1070         (if f
1071             (funcall (cdr f))
1072           ))
1073       )
1074     ))
1075
1076 (defun mime-view-next-content ()
1077   (interactive)
1078   (let ((pcl mime::preview/content-list)
1079         (p (point))
1080         beg)
1081     (catch 'tag
1082       (while pcl
1083         (setq beg (mime::preview-content-info/point-min (car pcl)))
1084         (if (< p beg)
1085             (throw 'tag (goto-char beg))
1086           )
1087         (setq pcl (cdr pcl))
1088         )
1089       (let ((f (assq mime::preview/original-major-mode
1090                      mime-view-over-to-next-method-alist)))
1091         (if f
1092             (funcall (cdr f))
1093           ))
1094       )
1095     ))
1096
1097 (defun mime-view-scroll-up-content (&optional h)
1098   (interactive)
1099   (or h
1100       (setq h (- (window-height) 1))
1101       )
1102   (if (= (point) (point-max))
1103       (let ((f (assq mime::preview/original-major-mode
1104                      mime-view-over-to-next-method-alist)))
1105         (if f
1106             (funcall (cdr f))
1107           ))
1108     (let ((pcl mime::preview/content-list)
1109           (p (point))
1110           np beg)
1111       (setq np
1112             (or (catch 'tag
1113                   (while pcl
1114                     (setq beg (mime::preview-content-info/point-min (car pcl)))
1115                     (if (< p beg)
1116                         (throw 'tag beg)
1117                       )
1118                     (setq pcl (cdr pcl))
1119                     ))
1120                 (point-max)))
1121       (forward-line h)
1122       (if (> (point) np)
1123           (goto-char np)
1124         )
1125       ;;(show-subtree)
1126       ))
1127   )
1128
1129 (defun mime-view-scroll-down-content (&optional h)
1130   (interactive)
1131   (or h
1132       (setq h (- (window-height) 1))
1133       )
1134   (if (= (point) (point-min))
1135       (let ((f (assq mime::preview/original-major-mode
1136                      mime-view-over-to-previous-method-alist)))
1137         (if f
1138             (funcall (cdr f))
1139           ))
1140     (let ((pcl mime::preview/content-list)
1141           (p (point))
1142           pp beg)
1143       (setq pp
1144             (or (let ((i (- (length pcl) 1)))
1145                   (catch 'tag
1146                     (while (> i 0)
1147                       (setq beg (mime::preview-content-info/point-min
1148                                  (nth i pcl)))
1149                       (if (> p beg)
1150                           (throw 'tag beg)
1151                         )
1152                       (setq i (- i 1))
1153                       )))
1154                 (point-min)))
1155       (forward-line (- h))
1156       (if (< (point) pp)
1157           (goto-char pp)
1158         )))
1159   )
1160
1161 (defun mime-view-next-line-content ()
1162   (interactive)
1163   (mime-view-scroll-up-content 1)
1164   )
1165
1166 (defun mime-view-previous-line-content ()
1167   (interactive)
1168   (mime-view-scroll-down-content 1)
1169   )
1170
1171 (defun mime-view-quit ()
1172   (interactive)
1173   (let ((r (save-excursion
1174              (set-buffer (mime::preview-content-info/buffer
1175                           (mime-preview/point-pcinfo (point))))
1176              (assq major-mode mime-view-quitting-method-alist)
1177              )))
1178     (if r
1179         (funcall (cdr r))
1180       )))
1181
1182 (defun mime-view-show-summary ()
1183   (interactive)
1184   (let ((r (save-excursion
1185              (set-buffer
1186               (mime::preview-content-info/buffer
1187                (mime-preview/point-pcinfo (point)))
1188               )
1189              (assq major-mode mime-view-show-summary-method)
1190              )))
1191     (if r
1192         (funcall (cdr r))
1193       )))
1194
1195 (defun mime-view-kill-buffer ()
1196   (interactive)
1197   (kill-buffer (current-buffer))
1198   )
1199
1200
1201 ;;; @ end
1202 ;;;
1203
1204 (provide 'mime-view)
1205
1206 (run-hooks 'mime-view-load-hook)
1207
1208 ;;; mime-view.el ends here