mime-view.el

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