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