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