mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Created: 1994/07/13
   7 ;;      Renamed: 1994/08/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 (Sample of Elastic 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 'emu)
  31 (require 'mime)
  32 (require 'semi-def)
  33 (require 'calist)
  34 (require 'alist)
  35 (require 'mailcap)
  36
  37
  38 ;;; @ version
  39 ;;;
  40
  41 (defconst mime-view-version
  42   (concat (mime-product-name mime-user-interface-product) " MIME-View "
  43           (mapconcat #'number-to-string
  44                      (mime-product-version mime-user-interface-product) ".")
  45           " (" (mime-product-code-name mime-user-interface-product) ")"))
  46
  47
  48 ;;; @ variables
  49 ;;;
  50
  51 (defgroup mime-view nil
  52   "MIME view mode"
  53   :group 'mime)
  54
  55 (defcustom mime-view-find-every-acting-situation t
  56   "*Find every available acting-situation if non-nil."
  57   :group 'mime-view
  58   :type 'boolean)
  59
  60 (defcustom mime-acting-situation-examples-file "~/.mime-example"
  61   "*File name of example about acting-situation demonstrated by user."
  62   :group 'mime-view
  63   :type 'file)
  64
  65 (defcustom mime-preview-move-scroll nil
  66   "*Decides whether to scroll when moving to next entity.
  67 When t, scroll the buffer. Non-nil but not t means scroll when
  68 the next entity is within next-screen-context-lines from top or
  69 buttom. Nil means don't scroll at all."
  70   :group 'mime-view
  71   :type '(choice (const :tag "Off" nil)
  72                  (const :tag "On" t)
  73                  (sexp :tag "Situation" 1)))
  74
  75 ;;; @ in raw-buffer (representation space)
  76 ;;;
  77
  78 (defvar mime-preview-buffer nil
  79   "MIME-preview buffer corresponding with the (raw) buffer.")
  80 (make-variable-buffer-local 'mime-preview-buffer)
  81
  82
  83 (defvar mime-raw-representation-type-alist
  84   '((mime-show-message-mode     . binary)
  85     (mime-temp-message-mode     . binary)
  86     (t                          . cooked)
  87     )
  88   "Alist of major-mode vs. representation-type of mime-raw-buffer.
  89 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
  90 major-mode or t.  t means default.  REPRESENTATION-TYPE must be
  91 `binary' or `cooked'.")
  92
  93
  94 ;; (defun mime-raw-find-entity-from-point (point &optional message-info)
  95 ;;   "Return entity from POINT in mime-raw-buffer.
  96 ;; If optional argument MESSAGE-INFO is not specified,
  97 ;; `mime-message-structure' is used."
  98 ;;   (or message-info
  99 ;;       (setq message-info mime-message-structure))
 100 ;;   (if (and (<= (mime-entity-point-min message-info) point)
 101 ;;            (<= point (mime-entity-point-max message-info)))
 102 ;;       (let ((children (mime-entity-children message-info)))
 103 ;;         (catch 'tag
 104 ;;           (while children
 105 ;;             (let ((ret
 106 ;;                    (mime-raw-find-entity-from-point point (car children))))
 107 ;;               (if ret
 108 ;;                   (throw 'tag ret)
 109 ;;                 ))
 110 ;;             (setq children (cdr children)))
 111 ;;           message-info))))
 112 ;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.")
 113
 114
 115 ;;; @ in preview-buffer (presentation space)
 116 ;;;
 117
 118 (defvar mime-mother-buffer nil
 119   "Mother buffer corresponding with the (MIME-preview) buffer.
 120 If current MIME-preview buffer is generated by other buffer, such as
 121 message/partial, it is called `mother-buffer'.")
 122 (make-variable-buffer-local 'mime-mother-buffer)
 123
 124 ;; (defvar mime-raw-buffer nil
 125 ;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
 126 ;; (make-variable-buffer-local 'mime-raw-buffer)
 127
 128 (defvar mime-preview-original-window-configuration nil
 129   "Window-configuration before mime-view-mode is called.")
 130 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 131
 132 (defun mime-preview-original-major-mode (&optional recursive point)
 133   "Return major-mode of original buffer.
 134 If optional argument RECURSIVE is non-nil and current buffer has
 135 mime-mother-buffer, it returns original major-mode of the
 136 mother-buffer."
 137   (if (and recursive mime-mother-buffer)
 138       (save-excursion
 139         (set-buffer mime-mother-buffer)
 140         (mime-preview-original-major-mode recursive)
 141         )
 142     (cdr (assq 'major-mode
 143                (get-text-property (or point
 144                                       (if (> (point) (buffer-size))
 145                                           (max (1- (point-max)) (point-min))
 146                                         (point)))
 147                                   'mime-view-situation)))))
 148
 149
 150 ;;; @ entity information
 151 ;;;
 152
 153 (defun mime-entity-situation (entity &optional situation)
 154   "Return situation of ENTITY."
 155   (let (rest param name)
 156     ;; Content-Type
 157     (unless (assq 'type situation)
 158       (setq rest (or (mime-entity-content-type entity)
 159                      (make-mime-content-type 'text 'plain))
 160             situation (cons (car rest) situation)
 161             rest (cdr rest))
 162       )
 163     (unless (assq 'subtype situation)
 164       (or rest
 165           (setq rest (or (cdr (mime-entity-content-type entity))
 166                          '((subtype . plain)))))
 167       (setq situation (cons (car rest) situation)
 168             rest (cdr rest))
 169       )
 170     (while rest
 171       (setq param (car rest))
 172       (or (assoc (car param) situation)
 173           (setq situation (cons param situation)))
 174       (setq rest (cdr rest)))
 175
 176     ;; Content-Disposition
 177     (setq rest nil)
 178     (unless (assq 'disposition-type situation)
 179       (setq rest (mime-entity-content-disposition entity))
 180       (if rest
 181           (setq situation (cons (cons 'disposition-type
 182                                       (mime-content-disposition-type rest))
 183                                 situation)
 184                 rest (mime-content-disposition-parameters rest))
 185         ))
 186     (while rest
 187       (setq param (car rest)
 188             name (car param))
 189       (if (cond ((string= name "filename")
 190                  (if (assq 'filename situation)
 191                      nil
 192                    (setq name 'filename)))
 193                 ((string= name "creation-date")
 194                  (if (assq 'creation-date situation)
 195                      nil
 196                    (setq name 'creation-date)))
 197                 ((string= name "modification-date")
 198                  (if (assq 'modification-date situation)
 199                      nil
 200                    (setq name 'modification-date)))
 201                 ((string= name "read-date")
 202                  (if (assq 'read-date situation)
 203                      nil
 204                    (setq name 'read-date)))
 205                 ((string= name "size")
 206                  (if (assq 'size situation)
 207                      nil
 208                    (setq name 'size)))
 209                 (t (setq name (cons 'disposition name))
 210                    (if (assoc name situation)
 211                        nil
 212                      name)))
 213           (setq situation
 214                 (cons (cons name (cdr param))
 215                       situation)))
 216       (setq rest (cdr rest)))
 217
 218     ;; Content-Transfer-Encoding
 219     (or (assq 'encoding situation)
 220         (setq situation
 221               (cons (cons 'encoding (or (mime-entity-encoding entity)
 222                                         "7bit"))
 223                     situation)))
 224
 225     situation))
 226
 227 (defun mime-view-entity-title (entity)
 228   (or (mime-entity-read-field entity 'Content-Description)
 229       (mime-entity-read-field entity 'Subject)
 230       (mime-entity-filename entity)
 231       ""))
 232
 233
 234 ;; (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 235 ;;   "Return entity-node-id from POINT in mime-raw-buffer.
 236 ;; If optional argument MESSAGE-INFO is not specified,
 237 ;; `mime-message-structure' is used."
 238 ;;   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 239
 240 ;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.")
 241
 242 ;; (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 243 ;;   "Return entity-number from POINT in mime-raw-buffer.
 244 ;; If optional argument MESSAGE-INFO is not specified,
 245 ;; `mime-message-structure' is used."
 246 ;;   (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
 247
 248 ;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.")
 249
 250 ;; (defun mime-raw-flatten-message-info (&optional message-info)
 251 ;;   "Return list of entity in mime-raw-buffer.
 252 ;; If optional argument MESSAGE-INFO is not specified,
 253 ;; `mime-message-structure' is used."
 254 ;;   (or message-info
 255 ;;       (setq message-info mime-message-structure))
 256 ;;   (let ((dest (list message-info))
 257 ;;         (rcl (mime-entity-children message-info)))
 258 ;;     (while rcl
 259 ;;       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 260 ;;       (setq rcl (cdr rcl)))
 261 ;;     dest))
 262
 263
 264 ;;; @ presentation of preview
 265 ;;;
 266
 267 ;;; @@ entity-button
 268 ;;;
 269
 270 ;;; @@@ predicate function
 271 ;;;
 272
 273 (defun mime-view-entity-button-visible-p (entity)
 274   "Return non-nil if header of ENTITY is visible.
 275 Please redefine this function if you want to change default setting."
 276   (let ((media-type (mime-entity-media-type entity))
 277         (media-subtype (mime-entity-media-subtype entity)))
 278     (or (not (eq media-type 'application))
 279         (and (not (eq media-subtype 'x-selection))
 280              (or (not (eq media-subtype 'octet-stream))
 281                  (let ((mother-entity (mime-entity-parent entity)))
 282                    (or (not (eq (mime-entity-media-type mother-entity)
 283                                 'multipart))
 284                        (not (eq (mime-entity-media-subtype mother-entity)
 285                                 'encrypted)))
 286                    )
 287                  )))))
 288
 289 ;;; @@@ entity button generator
 290 ;;;
 291
 292 (defun mime-view-insert-entity-button (entity)
 293   "Insert entity-button of ENTITY."
 294   (let ((entity-node-id (mime-entity-node-id entity))
 295         (params (mime-entity-parameters entity))
 296         (subject (mime-view-entity-title entity)))
 297     (mime-insert-button
 298      (let ((access-type (assoc "access-type" params))
 299            (num (or (cdr (assoc "x-part-number" params))
 300                     (if (consp entity-node-id)
 301                         (mapconcat (function
 302                                     (lambda (num)
 303                                       (format "%s" (1+ num))
 304                                       ))
 305                                    (reverse entity-node-id) ".")
 306                       "0"))
 307                 ))
 308        (cond (access-type
 309               (let ((server (assoc "server" params)))
 310                 (setq access-type (cdr access-type))
 311                 (if server
 312                     (format "%s %s ([%s] %s)"
 313                             num subject access-type (cdr server))
 314                 (let ((site (cdr (assoc "site" params)))
 315                       (dir (cdr (assoc "directory" params)))
 316                       (url (cdr (assoc "url" params)))
 317                       )
 318                   (if url
 319                       (format "%s %s ([%s] %s)"
 320                               num subject access-type url)
 321                     (format "%s %s ([%s] %s:%s)"
 322                             num subject access-type site dir))
 323                   )))
 324             )
 325            (t
 326             (let ((media-type (mime-entity-media-type entity))
 327                   (media-subtype (mime-entity-media-subtype entity))
 328                   (charset (cdr (assoc "charset" params)))
 329                   (encoding (mime-entity-encoding entity)))
 330               (concat
 331                num " " subject
 332                (let ((rest
 333                       (format " <%s/%s%s%s>"
 334                               media-type media-subtype
 335                               (if charset
 336                                   (concat "; " charset)
 337                                 "")
 338                               (if encoding
 339                                   (concat " (" encoding ")")
 340                                 ""))))
 341                  (if (>= (+ (current-column)(length rest))(window-width))
 342                      "\n\t")
 343                  rest)))
 344             )))
 345      (function mime-preview-play-current-entity))
 346     ))
 347
 348
 349 ;;; @@ entity-header
 350 ;;;
 351
 352 (defvar mime-header-presentation-method-alist nil
 353   "Alist of major mode vs. corresponding header-presentation-method functions.
 354 Each element looks like (SYMBOL . FUNCTION).
 355 SYMBOL must be major mode in raw-buffer or t.  t means default.
 356 Interface of FUNCTION must be (ENTITY SITUATION).")
 357
 358 (defvar mime-view-ignored-field-list
 359   '(".*Received:" ".*Path:" ".*Id:" "^References:"
 360     "^Replied:" "^Errors-To:"
 361     "^Lines:" "^Sender:" ".*Host:" "^Xref:"
 362     "^Content-Type:" "^Precedence:"
 363     "^Status:" "^X-VM-.*:")
 364   "All fields that match this list will be hidden in MIME preview buffer.
 365 Each elements are regexp of field-name.")
 366
 367 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
 368   "All fields that match this list will be displayed in MIME preview buffer.
 369 Each elements are regexp of field-name.")
 370
 371
 372 ;;; @@ entity-body
 373 ;;;
 374
 375 ;;; @@@ predicate function
 376 ;;;
 377
 378 (in-calist-package 'mime-view)
 379
 380 (defun mime-calist::field-match-method-as-default-rule (calist
 381                                                         field-type field-value)
 382   (let ((s-field (assq field-type calist)))
 383     (cond ((null s-field)
 384            (cons (cons field-type field-value) calist)
 385            )
 386           (t calist))))
 387
 388 (define-calist-field-match-method
 389   'header #'mime-calist::field-match-method-as-default-rule)
 390
 391 (define-calist-field-match-method
 392   'body #'mime-calist::field-match-method-as-default-rule)
 393
 394
 395 (defvar mime-preview-condition nil
 396   "Condition-tree about how to display entity.")
 397
 398 (ctree-set-calist-strictly
 399  'mime-preview-condition '((type . application)(subtype . octet-stream)
 400                            (encoding . nil)
 401                            (body . visible)))
 402 (ctree-set-calist-strictly
 403  'mime-preview-condition '((type . application)(subtype . octet-stream)
 404                            (encoding . "7bit")
 405                            (body . visible)))
 406 (ctree-set-calist-strictly
 407  'mime-preview-condition '((type . application)(subtype . octet-stream)
 408                            (encoding . "8bit")
 409                            (body . visible)))
 410
 411 (ctree-set-calist-strictly
 412  'mime-preview-condition '((type . application)(subtype . pgp)
 413                            (body . visible)))
 414
 415 (ctree-set-calist-strictly
 416  'mime-preview-condition '((type . application)(subtype . x-latex)
 417                            (body . visible)))
 418
 419 (ctree-set-calist-strictly
 420  'mime-preview-condition '((type . application)(subtype . x-selection)
 421                            (body . visible)))
 422
 423 (ctree-set-calist-strictly
 424  'mime-preview-condition '((type . application)(subtype . x-comment)
 425                            (body . visible)))
 426
 427 (ctree-set-calist-strictly
 428  'mime-preview-condition '((type . message)(subtype . delivery-status)
 429                            (body . visible)))
 430
 431 (ctree-set-calist-strictly
 432  'mime-preview-condition
 433  '((body . visible)
 434    (body-presentation-method . mime-display-text/plain)))
 435
 436 (ctree-set-calist-strictly
 437  'mime-preview-condition
 438  '((type . nil)
 439    (body . visible)
 440    (body-presentation-method . mime-display-text/plain)))
 441
 442 (ctree-set-calist-strictly
 443  'mime-preview-condition
 444  '((type . text)(subtype . enriched)
 445    (body . visible)
 446    (body-presentation-method . mime-display-text/enriched)))
 447
 448 (ctree-set-calist-strictly
 449  'mime-preview-condition
 450  '((type . text)(subtype . richtext)
 451    (body . visible)
 452    (body-presentation-method . mime-display-text/richtext)))
 453
 454 (ctree-set-calist-strictly
 455  'mime-preview-condition
 456  '((type . application)(subtype . x-postpet)
 457    (body . visible)
 458    (body-presentation-method . mime-display-application/x-postpet)))
 459
 460 (ctree-set-calist-strictly
 461  'mime-preview-condition
 462  '((type . text)(subtype . t)
 463    (body . visible)
 464    (body-presentation-method . mime-display-text/plain)))
 465
 466 (ctree-set-calist-strictly
 467  'mime-preview-condition
 468  '((type . multipart)(subtype . alternative)
 469    (body . visible)
 470    (body-presentation-method . mime-display-multipart/alternative)))
 471
 472 (ctree-set-calist-strictly
 473  'mime-preview-condition '((type . message)(subtype . partial)
 474                            (body-presentation-method
 475                             . mime-display-message/partial-button)))
 476
 477 (ctree-set-calist-strictly
 478  'mime-preview-condition '((type . message)(subtype . rfc822)
 479                            (body-presentation-method . nil)
 480                            (childrens-situation (header . visible)
 481                                                 (entity-button . invisible))))
 482
 483 (ctree-set-calist-strictly
 484  'mime-preview-condition '((type . message)(subtype . news)
 485                            (body-presentation-method . nil)
 486                            (childrens-situation (header . visible)
 487                                                 (entity-button . invisible))))
 488
 489
 490 ;;; @@@ entity presentation
 491 ;;;
 492
 493 (defun mime-display-text/plain (entity situation)
 494   (save-restriction
 495     (narrow-to-region (point-max)(point-max))
 496     (mime-insert-text-content entity)
 497     (run-hooks 'mime-text-decode-hook)
 498     (goto-char (point-max))
 499     (if (not (eq (char-after (1- (point))) ?\n))
 500         (insert "\n")
 501       )
 502     (mime-add-url-buttons)
 503     (run-hooks 'mime-display-text/plain-hook)
 504     ))
 505
 506 (defun mime-display-text/richtext (entity situation)
 507   (save-restriction
 508     (narrow-to-region (point-max)(point-max))
 509     (mime-insert-text-content entity)
 510     (run-hooks 'mime-text-decode-hook)
 511     (let ((beg (point-min)))
 512       (remove-text-properties beg (point-max) '(face nil))
 513       (richtext-decode beg (point-max))
 514       )))
 515
 516 (defun mime-display-text/enriched (entity situation)
 517   (save-restriction
 518     (narrow-to-region (point-max)(point-max))
 519     (mime-insert-text-content entity)
 520     (run-hooks 'mime-text-decode-hook)
 521     (let ((beg (point-min)))
 522       (remove-text-properties beg (point-max) '(face nil))
 523       (enriched-decode beg (point-max))
 524       )))
 525
 526 (put 'unpack 'lisp-indent-function 1)
 527 (defmacro unpack (string &rest body)
 528   `(let* ((*unpack*string* (string-as-unibyte ,string))
 529           (*unpack*index* 0))
 530      ,@body))
 531
 532 (defun unpack-skip (len)
 533   (setq *unpack*index* (+ len *unpack*index*)))
 534
 535 (defun unpack-fixed (len)
 536   (prog1
 537       (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
 538     (unpack-skip len)))
 539
 540 (defun unpack-byte ()
 541   (char-int (aref (unpack-fixed 1) 0)))
 542
 543 (defun unpack-short ()
 544   (let* ((b0 (unpack-byte))
 545          (b1 (unpack-byte)))
 546     (+ (* 256 b0) b1)))
 547
 548 (defun unpack-long ()
 549   (let* ((s0 (unpack-short))
 550          (s1 (unpack-short)))
 551     (+ (* 65536 s0) s1)))
 552
 553 (defun unpack-string ()
 554   (let ((len (unpack-byte)))
 555     (unpack-fixed len)))
 556
 557 (defun unpack-string-sjis ()
 558   (decode-mime-charset-string (unpack-string) 'shift_jis))
 559
 560 (defun postpet-decode (string)
 561   (condition-case nil
 562       (unpack string
 563         (let (res)
 564           (unpack-skip 4)
 565           (set-alist 'res 'carryingcount (unpack-long))
 566           (unpack-skip 8)
 567           (set-alist 'res 'sentyear (unpack-short))
 568           (set-alist 'res 'sentmonth (unpack-short))
 569           (set-alist 'res 'sentday (unpack-short))
 570           (unpack-skip 8)
 571           (set-alist 'res 'petname (unpack-string-sjis))
 572           (set-alist 'res 'owner (unpack-string-sjis))
 573           (set-alist 'res 'pettype (unpack-fixed 4))
 574           (set-alist 'res 'health (unpack-short))
 575           (unpack-skip 2)
 576           (set-alist 'res 'sex (unpack-long))
 577           (unpack-skip 1)
 578           (set-alist 'res 'brain (unpack-byte))
 579           (unpack-skip 39)
 580           (set-alist 'res 'happiness (unpack-byte))
 581           (unpack-skip 14)
 582           (set-alist 'res 'petbirthyear (unpack-short))
 583           (set-alist 'res 'petbirthmonth (unpack-short))
 584           (set-alist 'res 'petbirthday (unpack-short))
 585           (unpack-skip 8)
 586           (set-alist 'res 'from (unpack-string))
 587           (unpack-skip 5)
 588           (unpack-skip 160)
 589           (unpack-skip 4)
 590           (unpack-skip 8)
 591           (unpack-skip 8)
 592           (unpack-skip 26)
 593           (set-alist 'res 'treasure (unpack-short))
 594           (set-alist 'res 'money (unpack-long))
 595           res))
 596     (error nil)))
 597
 598 (defun mime-display-application/x-postpet (entity situation)
 599   (save-restriction
 600     (narrow-to-region (point-max)(point-max))
 601     (let ((pet (postpet-decode (mime-entity-content entity))))
 602       (if pet
 603           (insert "Petname: " (cdr (assq 'petname pet)) "\n"
 604                   "Owner: " (cdr (assq 'owner pet)) "\n"
 605                   "Pettype: " (cdr (assq 'pettype pet)) "\n"
 606                   "From: " (cdr (assq 'from pet)) "\n"
 607                   "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n"
 608                   "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) "\n"
 609                   "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n"
 610                   "SentDay: " (int-to-string (cdr (assq 'sentday pet))) "\n"
 611                   "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n"
 612                   "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n"
 613                   "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n"
 614                   "Health: " (int-to-string (cdr (assq 'health pet))) "\n"
 615                   "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n"
 616                   "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n"
 617                   "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n"
 618                   "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n"
 619                   "Money: " (int-to-string (cdr (assq 'money pet))) "\n"
 620                   )
 621         (insert "Invalid format\n"))
 622       (run-hooks 'mime-display-application/x-postpet-hook))))
 623
 624
 625 (defvar mime-view-announcement-for-message/partial
 626   (if (and (>= emacs-major-version 19) window-system)
 627       "\
 628 \[[ This is message/partial style split message. ]]
 629 \[[ Please press `v' key in this buffer          ]]
 630 \[[ or click here by mouse button-2.             ]]"
 631     "\
 632 \[[ This is message/partial style split message. ]]
 633 \[[ Please press `v' key in this buffer.         ]]"
 634     ))
 635
 636 (defun mime-display-message/partial-button (&optional entity situation)
 637   (save-restriction
 638     (goto-char (point-max))
 639     (if (not (search-backward "\n\n" nil t))
 640         (insert "\n")
 641       )
 642     (goto-char (point-max))
 643     (narrow-to-region (point-max)(point-max))
 644     (insert mime-view-announcement-for-message/partial)
 645     (mime-add-button (point-min)(point-max)
 646                      #'mime-preview-play-current-entity)
 647     ))
 648
 649 (defun mime-display-multipart/mixed (entity situation)
 650   (let ((children (mime-entity-children entity))
 651         (original-major-mode-cell (assq 'major-mode situation))
 652         (default-situation
 653           (cdr (assq 'childrens-situation situation))))
 654     (if original-major-mode-cell
 655         (setq default-situation
 656               (cons original-major-mode-cell default-situation)))
 657     (while children
 658       (mime-display-entity (car children) nil default-situation)
 659       (setq children (cdr children))
 660       )))
 661
 662 (defcustom mime-view-type-subtype-score-alist
 663   '(((text . enriched) . 3)
 664     ((text . richtext) . 2)
 665     ((text . plain)    . 1)
 666     (t . 0))
 667   "Alist MEDIA-TYPE vs corresponding score.
 668 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 669   :group 'mime-view
 670   :type '(repeat (cons (choice :tag "Media-Type"
 671                                (cons :tag "Type/Subtype"
 672                                      (symbol :tag "Primary-type")
 673                                      (symbol :tag "Subtype"))
 674                                (symbol :tag "Type")
 675                                (const :tag "Default" t))
 676                        integer)))
 677
 678 (defun mime-display-multipart/alternative (entity situation)
 679   (let* ((children (mime-entity-children entity))
 680          (original-major-mode-cell (assq 'major-mode situation))
 681          (default-situation
 682            (cdr (assq 'childrens-situation situation)))
 683          (i 0)
 684          (p 0)
 685          (max-score 0)
 686          situations)
 687     (if original-major-mode-cell
 688         (setq default-situation
 689               (cons original-major-mode-cell default-situation)))
 690     (setq situations
 691           (mapcar (function
 692                    (lambda (child)
 693                      (let ((situation
 694                             (or (ctree-match-calist
 695                                  mime-preview-condition
 696                                  (append (mime-entity-situation child)
 697                                          default-situation))
 698                                 default-situation)))
 699                        (if (cdr (assq 'body-presentation-method situation))
 700                            (let ((score
 701                                   (cdr
 702                                    (or (assoc
 703                                         (cons
 704                                          (cdr (assq 'type situation))
 705                                          (cdr (assq 'subtype situation)))
 706                                         mime-view-type-subtype-score-alist)
 707                                        (assq
 708                                         (cdr (assq 'type situation))
 709                                         mime-view-type-subtype-score-alist)
 710                                        (assq
 711                                         t
 712                                         mime-view-type-subtype-score-alist)
 713                                        ))))
 714                              (if (> score max-score)
 715                                  (setq p i
 716                                        max-score score)
 717                                )))
 718                        (setq i (1+ i))
 719                        situation)
 720                      ))
 721                   children))
 722     (setq i 0)
 723     (while children
 724       (let ((child (car children))
 725             (situation (car situations)))
 726         (mime-display-entity child (if (= i p)
 727                                        situation
 728                                      (del-alist 'body-presentation-method
 729                                                 (copy-alist situation))))
 730         )
 731       (setq children (cdr children)
 732             situations (cdr situations)
 733             i (1+ i))
 734       )))
 735
 736
 737 ;;; @ acting-condition
 738 ;;;
 739
 740 (defvar mime-acting-condition nil
 741   "Condition-tree about how to process entity.")
 742
 743 (if (file-readable-p mailcap-file)
 744     (let ((entries (mailcap-parse-file)))
 745       (while entries
 746         (let ((entry (car entries))
 747               view print shared)
 748           (while entry
 749             (let* ((field (car entry))
 750                    (field-type (car field)))
 751               (cond ((eq field-type 'view)  (setq view field))
 752                     ((eq field-type 'print) (setq print field))
 753                     ((memq field-type '(compose composetyped edit)))
 754                     (t (setq shared (cons field shared))))
 755               )
 756             (setq entry (cdr entry))
 757             )
 758           (setq shared (nreverse shared))
 759           (ctree-set-calist-with-default
 760            'mime-acting-condition
 761            (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 762           (if print
 763               (ctree-set-calist-with-default
 764                'mime-acting-condition
 765                (append shared
 766                        (list '(mode . "print")(cons 'method (cdr view))))
 767                ))
 768           )
 769         (setq entries (cdr entries))
 770         )))
 771
 772 (ctree-set-calist-strictly
 773  'mime-acting-condition
 774  '((type . application)(subtype . octet-stream)
 775    (mode . "play")
 776    (method . mime-detect-content)
 777    ))
 778
 779 (ctree-set-calist-with-default
 780  'mime-acting-condition
 781  '((mode . "extract")
 782    (method . mime-save-content)))
 783
 784 (ctree-set-calist-strictly
 785  'mime-acting-condition
 786  '((type . text)(subtype . x-rot13-47)(mode . "play")
 787    (method . mime-view-caesar)
 788    ))
 789 (ctree-set-calist-strictly
 790  'mime-acting-condition
 791  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
 792    (method . mime-view-caesar)
 793    ))
 794
 795 (ctree-set-calist-strictly
 796  'mime-acting-condition
 797  '((type . message)(subtype . rfc822)(mode . "play")
 798    (method . mime-view-message/rfc822)
 799    ))
 800 (ctree-set-calist-strictly
 801  'mime-acting-condition
 802  '((type . message)(subtype . partial)(mode . "play")
 803    (method . mime-store-message/partial-piece)
 804    ))
 805
 806 (ctree-set-calist-strictly
 807  'mime-acting-condition
 808  '((type . message)(subtype . external-body)
 809    ("access-type" . "anon-ftp")
 810    (method . mime-view-message/external-anon-ftp)
 811    ))
 812
 813 (ctree-set-calist-strictly
 814  'mime-acting-condition
 815  '((type . message)(subtype . external-body)
 816    ("access-type" . "url")
 817    (method . mime-view-message/external-url)
 818    ))
 819
 820 (ctree-set-calist-strictly
 821  'mime-acting-condition
 822  '((type . application)(subtype . octet-stream)
 823    (method . mime-save-content)
 824    ))
 825
 826
 827 ;;; @ quitting method
 828 ;;;
 829
 830 (defvar mime-preview-quitting-method-alist
 831   '((mime-show-message-mode
 832      . mime-preview-quitting-method-for-mime-show-message-mode))
 833   "Alist of major-mode vs. quitting-method of mime-view.")
 834
 835 (defvar mime-preview-over-to-previous-method-alist nil
 836   "Alist of major-mode vs. over-to-previous-method of mime-view.")
 837
 838 (defvar mime-preview-over-to-next-method-alist nil
 839   "Alist of major-mode vs. over-to-next-method of mime-view.")
 840
 841
 842 ;;; @ following method
 843 ;;;
 844
 845 (defvar mime-preview-following-method-alist nil
 846   "Alist of major-mode vs. following-method of mime-view.")
 847
 848 (defvar mime-view-following-required-fields-list
 849   '("From"))
 850
 851
 852 ;;; @ buffer setup
 853 ;;;
 854
 855 (defun mime-display-entity (entity &optional situation
 856                                    default-situation preview-buffer)
 857   (or preview-buffer
 858       (setq preview-buffer (current-buffer)))
 859   (let* (e nb ne nhb nbb)
 860     (mime-goto-header-start-point entity)
 861     (in-calist-package 'mime-view)
 862     (or situation
 863         (setq situation
 864               (or (ctree-match-calist mime-preview-condition
 865                                       (append (mime-entity-situation entity)
 866                                               default-situation))
 867                   default-situation)))
 868     (let ((button-is-invisible
 869            (eq (cdr (assq 'entity-button situation)) 'invisible))
 870           (header-is-visible
 871            (eq (cdr (assq 'header situation)) 'visible))
 872           (header-presentation-method
 873            (or (cdr (assq 'header-presentation-method situation))
 874                (cdr (assq (cdr (assq 'major-mode situation))
 875                           mime-header-presentation-method-alist))))
 876           (body-presentation-method
 877            (cdr (assq 'body-presentation-method situation)))
 878           (children (mime-entity-children entity)))
 879       (set-buffer preview-buffer)
 880       (setq nb (point))
 881       (narrow-to-region nb nb)
 882       (or button-is-invisible
 883           (if (mime-view-entity-button-visible-p entity)
 884               (mime-view-insert-entity-button entity)
 885             ))
 886       (when header-is-visible
 887         (setq nhb (point))
 888         (if header-presentation-method
 889             (funcall header-presentation-method entity situation)
 890           (mime-insert-header entity
 891                               mime-view-ignored-field-list
 892                               mime-view-visible-field-list))
 893         (run-hooks 'mime-display-header-hook)
 894         (put-text-property nhb (point-max) 'mime-view-entity-header entity)
 895         (goto-char (point-max))
 896         (insert "\n")
 897         )
 898       (setq nbb (point))
 899       (cond (children)
 900             ((functionp body-presentation-method)
 901              (funcall body-presentation-method entity situation)
 902              )
 903             (t
 904              (when button-is-invisible
 905                (goto-char (point-max))
 906                (mime-view-insert-entity-button entity)
 907                )
 908              (or header-is-visible
 909                  (progn
 910                    (goto-char (point-max))
 911                    (insert "\n")
 912                    ))
 913              ))
 914       (setq ne (point-max))
 915       (widen)
 916       (put-text-property nb ne 'mime-view-entity entity)
 917       (put-text-property nb ne 'mime-view-situation situation)
 918       (put-text-property nbb ne 'mime-view-entity-body entity)
 919       (goto-char ne)
 920       (if children
 921           (if (functionp body-presentation-method)
 922               (funcall body-presentation-method entity situation)
 923             (mime-display-multipart/mixed entity situation)
 924             ))
 925       )))
 926
 927
 928 ;;; @ MIME viewer mode
 929 ;;;
 930
 931 (defconst mime-view-menu-title "MIME-View")
 932 (defconst mime-view-menu-list
 933   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 934     (previous    "Move to previous entity" mime-preview-move-to-previous)
 935     (next        "Move to next entity"     mime-preview-move-to-next)
 936     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 937     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 938     (play        "Play current entity"     mime-preview-play-current-entity)
 939     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 940     (print       "Print current entity"    mime-preview-print-current-entity)
 941     )
 942   "Menu for MIME Viewer")
 943
 944 (cond ((featurep 'xemacs)
 945        (defvar mime-view-xemacs-popup-menu
 946          (cons mime-view-menu-title
 947                (mapcar (function
 948                         (lambda (item)
 949                           (vector (nth 1 item)(nth 2 item) t)
 950                           ))
 951                        mime-view-menu-list)))
 952        (defun mime-view-xemacs-popup-menu (event)
 953          "Popup the menu in the MIME Viewer buffer"
 954          (interactive "e")
 955          (select-window (event-window event))
 956          (set-buffer (event-buffer event))
 957          (popup-menu 'mime-view-xemacs-popup-menu))
 958        (defvar mouse-button-2 'button2)
 959        )
 960       (t
 961        (defvar mouse-button-2 [mouse-2])
 962        ))
 963
 964 (defun mime-view-define-keymap (&optional default)
 965   (let ((mime-view-mode-map (if (keymapp default)
 966                                 (copy-keymap default)
 967                               (make-sparse-keymap)
 968                               )))
 969     (define-key mime-view-mode-map
 970       "u"        (function mime-preview-move-to-upper))
 971     (define-key mime-view-mode-map
 972       "p"        (function mime-preview-move-to-previous))
 973     (define-key mime-view-mode-map
 974       "n"        (function mime-preview-move-to-next))
 975     (define-key mime-view-mode-map
 976       "\e\t"     (function mime-preview-move-to-previous))
 977     (define-key mime-view-mode-map
 978       "\t"       (function mime-preview-move-to-next))
 979     (define-key mime-view-mode-map
 980       " "        (function mime-preview-scroll-up-entity))
 981     (define-key mime-view-mode-map
 982       "\M- "     (function mime-preview-scroll-down-entity))
 983     (define-key mime-view-mode-map
 984       "\177"     (function mime-preview-scroll-down-entity))
 985     (define-key mime-view-mode-map
 986       "\C-m"     (function mime-preview-next-line-entity))
 987     (define-key mime-view-mode-map
 988       "\C-\M-m"  (function mime-preview-previous-line-entity))
 989     (define-key mime-view-mode-map
 990       "v"        (function mime-preview-play-current-entity))
 991     (define-key mime-view-mode-map
 992       "e"        (function mime-preview-extract-current-entity))
 993     (define-key mime-view-mode-map
 994       "\C-c\C-p" (function mime-preview-print-current-entity))
 995     (define-key mime-view-mode-map
 996       "a"        (function mime-preview-follow-current-entity))
 997     (define-key mime-view-mode-map
 998       "q"        (function mime-preview-quit))
 999     (define-key mime-view-mode-map
1000       "\C-c\C-x" (function mime-preview-kill-buffer))
1001     ;; (define-key mime-view-mode-map
1002     ;;   "<"        (function beginning-of-buffer))
1003     ;; (define-key mime-view-mode-map
1004     ;;   ">"        (function end-of-buffer))
1005     (define-key mime-view-mode-map
1006       "?"        (function describe-mode))
1007     (define-key mime-view-mode-map
1008       [tab] (function mime-preview-move-to-next))
1009     (define-key mime-view-mode-map
1010       [delete] (function mime-preview-scroll-down-entity))
1011     (define-key mime-view-mode-map
1012       [backspace] (function mime-preview-scroll-down-entity))
1013     (if (functionp default)
1014         (cond ((featurep 'xemacs)
1015                (set-keymap-default-binding mime-view-mode-map default)
1016                )
1017               (t
1018                (setq mime-view-mode-map
1019                      (append mime-view-mode-map (list (cons t default))))
1020                )))
1021     (if mouse-button-2
1022         (define-key mime-view-mode-map
1023           mouse-button-2 (function mime-button-dispatcher))
1024       )
1025     (cond ((featurep 'xemacs)
1026            (define-key mime-view-mode-map
1027              mouse-button-3 (function mime-view-xemacs-popup-menu))
1028            )
1029           ((>= emacs-major-version 19)
1030            (define-key mime-view-mode-map [menu-bar mime-view]
1031              (cons mime-view-menu-title
1032                    (make-sparse-keymap mime-view-menu-title)))
1033            (mapcar (function
1034                     (lambda (item)
1035                       (define-key mime-view-mode-map
1036                         (vector 'menu-bar 'mime-view (car item))
1037                         (cons (nth 1 item)(nth 2 item))
1038                         )
1039                       ))
1040                    (reverse mime-view-menu-list)
1041                    )
1042            ))
1043     (use-local-map mime-view-mode-map)
1044     (run-hooks 'mime-view-define-keymap-hook)
1045     ))
1046
1047 (defsubst mime-maybe-hide-echo-buffer ()
1048   "Clear mime-echo buffer and delete window for it."
1049   (let ((buf (get-buffer mime-echo-buffer-name)))
1050     (if buf
1051         (save-excursion
1052           (set-buffer buf)
1053           (erase-buffer)
1054           (let ((win (get-buffer-window buf)))
1055             (if win
1056                 (delete-window win)
1057               ))
1058           (bury-buffer buf)
1059           ))))
1060
1061 (defvar mime-view-redisplay nil)
1062
1063 ;;;###autoload
1064 (defun mime-display-message (message &optional preview-buffer
1065                                      mother default-keymap-or-function
1066                                      original-major-mode)
1067   "View MESSAGE in MIME-View mode.
1068
1069 Optional argument PREVIEW-BUFFER specifies the buffer of the
1070 presentation.  It must be either nil or a name of preview buffer.
1071
1072 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1073
1074 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1075 function.  If it is a keymap, keymap of MIME-View mode will be added
1076 to it.  If it is a function, it will be bound as default binding of
1077 keymap of MIME-View mode."
1078   (mime-maybe-hide-echo-buffer)
1079   (let ((win-conf (current-window-configuration)))
1080     (or preview-buffer
1081         (setq preview-buffer
1082               (concat "*Preview-" (mime-entity-name message) "*")))
1083     (or original-major-mode
1084         (setq original-major-mode
1085               (with-current-buffer (mime-entity-header-buffer message)
1086                 major-mode)))
1087     (let ((inhibit-read-only t))
1088       (set-buffer (get-buffer-create preview-buffer))
1089       (widen)
1090       (erase-buffer)
1091       (if mother
1092           (setq mime-mother-buffer mother)
1093         )
1094       (setq mime-preview-original-window-configuration win-conf)
1095       (setq major-mode 'mime-view-mode)
1096       (setq mode-name "MIME-View")
1097       (mime-display-entity message nil
1098                            `((entity-button . invisible)
1099                              (header . visible)
1100                              (major-mode . ,original-major-mode))
1101                            preview-buffer)
1102       (mime-view-define-keymap default-keymap-or-function)
1103       (let ((point
1104              (next-single-property-change (point-min) 'mime-view-entity)))
1105         (if point
1106             (goto-char point)
1107           (goto-char (point-min))
1108           (search-forward "\n\n" nil t)
1109           ))
1110       (run-hooks 'mime-view-mode-hook)
1111       (set-buffer-modified-p nil)
1112       (setq buffer-read-only t)
1113       preview-buffer)))
1114
1115 ;;;###autoload
1116 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1117                                    default-keymap-or-function
1118                                    representation-type)
1119   "View RAW-BUFFER in MIME-View mode.
1120 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1121 buffer.
1122 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1123 function.  If it is a keymap, keymap of MIME-View mode will be added
1124 to it.  If it is a function, it will be bound as default binding of
1125 keymap of MIME-View mode.
1126 Optional argument REPRESENTATION-TYPE is representation-type of
1127 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1128 `cooked' is used as default."
1129   (interactive)
1130   (or raw-buffer
1131       (setq raw-buffer (current-buffer)))
1132   (or representation-type
1133       (setq representation-type
1134             (save-excursion
1135               (set-buffer raw-buffer)
1136               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1137                        (assq t mime-raw-representation-type-alist)))
1138               )))
1139   (if (eq representation-type 'binary)
1140       (setq representation-type 'buffer)
1141     )
1142   (setq preview-buffer (mime-display-message
1143                         (mime-open-entity representation-type raw-buffer)
1144                         preview-buffer mother default-keymap-or-function))
1145   (or (get-buffer-window preview-buffer)
1146       (let ((r-win (get-buffer-window raw-buffer)))
1147         (if r-win
1148             (set-window-buffer r-win preview-buffer)
1149           (let ((m-win (and mother (get-buffer-window mother))))
1150             (if m-win
1151                 (set-window-buffer m-win preview-buffer)
1152               (switch-to-buffer preview-buffer)
1153               ))))))
1154
1155 (defun mime-view-mode (&optional mother ctl encoding
1156                                  raw-buffer preview-buffer
1157                                  default-keymap-or-function)
1158   "Major mode for viewing MIME message.
1159
1160 Here is a list of the standard keys for mime-view-mode.
1161
1162 key             feature
1163 ---             -------
1164
1165 u               Move to upper content
1166 p or M-TAB      Move to previous content
1167 n or TAB        Move to next content
1168 SPC             Scroll up or move to next content
1169 M-SPC or DEL    Scroll down or move to previous content
1170 RET             Move to next line
1171 M-RET           Move to previous line
1172 v               Decode current content as `play mode'
1173 e               Decode current content as `extract mode'
1174 C-c C-p         Decode current content as `print mode'
1175 a               Followup to current content.
1176 q               Quit
1177 button-2        Move to point under the mouse cursor
1178                 and decode current content as `play mode'
1179 "
1180   (interactive)
1181   (unless mime-view-redisplay
1182     (save-excursion
1183       (if raw-buffer (set-buffer raw-buffer))
1184       (let ((type
1185              (cdr
1186               (or (assq major-mode mime-raw-representation-type-alist)
1187                   (assq t mime-raw-representation-type-alist)))))
1188         (if (eq type 'binary)
1189             (setq type 'buffer)
1190           )
1191         (setq mime-message-structure (mime-open-entity type raw-buffer))
1192         (or (mime-entity-content-type mime-message-structure)
1193             (mime-entity-set-content-type-internal
1194              mime-message-structure ctl))
1195         )
1196       (or (mime-entity-encoding mime-message-structure)
1197           (mime-entity-set-encoding-internal mime-message-structure encoding))
1198       ))
1199   (mime-display-message mime-message-structure preview-buffer
1200                         mother default-keymap-or-function)
1201   )
1202
1203
1204 ;;; @@ playing
1205 ;;;
1206
1207 (autoload 'mime-preview-play-current-entity "mime-play"
1208   "Play current entity." t)
1209
1210 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1211   "Extract current entity into file (maybe).
1212 It decodes current entity to call internal or external method as
1213 \"extract\" mode.  The method is selected from variable
1214 `mime-acting-condition'."
1215   (interactive "P")
1216   (mime-preview-play-current-entity ignore-examples "extract")
1217   )
1218
1219 (defun mime-preview-print-current-entity (&optional ignore-examples)
1220   "Print current entity (maybe).
1221 It decodes current entity to call internal or external method as
1222 \"print\" mode.  The method is selected from variable
1223 `mime-acting-condition'."
1224   (interactive "P")
1225   (mime-preview-play-current-entity ignore-examples "print")
1226   )
1227
1228
1229 ;;; @@ following
1230 ;;;
1231
1232 (defun mime-preview-follow-current-entity ()
1233   "Write follow message to current entity.
1234 It calls following-method selected from variable
1235 `mime-preview-following-method-alist'."
1236   (interactive)
1237   (let (entity)
1238     (while (null (setq entity
1239                        (get-text-property (point) 'mime-view-entity)))
1240       (backward-char)
1241       )
1242     (let* ((p-beg
1243             (previous-single-property-change (point) 'mime-view-entity))
1244            p-end
1245            ph-end
1246            (entity-node-id (mime-entity-node-id entity))
1247            (len (length entity-node-id))
1248            )
1249       (cond ((null p-beg)
1250              (setq p-beg
1251                    (if (eq (next-single-property-change (point-min)
1252                                                         'mime-view-entity)
1253                            (point))
1254                        (point)
1255                      (point-min)))
1256              )
1257             ((eq (next-single-property-change p-beg 'mime-view-entity)
1258                  (point))
1259              (setq p-beg (point))
1260              ))
1261       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1262       (cond ((null p-end)
1263              (setq p-end (point-max))
1264              )
1265             ((null entity-node-id)
1266              (setq p-end (point-max))
1267              )
1268             (t
1269              (save-excursion
1270                (goto-char p-end)
1271                (catch 'tag
1272                  (let (e)
1273                    (while (setq e
1274                                 (next-single-property-change
1275                                  (point) 'mime-view-entity))
1276                      (goto-char e)
1277                      (let ((rc (mime-entity-node-id
1278                                 (get-text-property (point)
1279                                                    'mime-view-entity))))
1280                        (or (equal entity-node-id
1281                                   (nthcdr (- (length rc) len) rc))
1282                            (throw 'tag nil)
1283                            ))
1284                      (setq p-end e)
1285                      ))
1286                  (setq p-end (point-max))
1287                  ))
1288              ))
1289       (setq ph-end
1290             (previous-single-property-change p-end 'mime-view-entity-header))
1291       (if (or (null ph-end)
1292               (< ph-end p-beg))
1293           (setq ph-end p-beg)
1294         )
1295       (let* ((mode (mime-preview-original-major-mode 'recursive))
1296              (new-name
1297               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1298              new-buf
1299              (the-buf (current-buffer))
1300              fields)
1301         (save-excursion
1302           (set-buffer (setq new-buf (get-buffer-create new-name)))
1303           (erase-buffer)
1304           (insert-buffer-substring the-buf ph-end p-end)
1305           (when (= ph-end p-beg)
1306             (goto-char (point-min))
1307             (insert ?\n))
1308           (goto-char (point-min))
1309           (let ((current-entity
1310                  (if (and (eq (mime-entity-media-type entity) 'message)
1311                           (eq (mime-entity-media-subtype entity) 'rfc822))
1312                      (mime-entity-children entity)
1313                    entity))
1314                 str)
1315             (while (and current-entity
1316                         (progn
1317                           (setq str
1318                                 (with-current-buffer
1319                                     (mime-entity-header-buffer current-entity)
1320                                   (save-restriction
1321                                     (narrow-to-region
1322                                      (mime-entity-header-start-point
1323                                       current-entity)
1324                                      (mime-entity-header-end-point
1325                                       current-entity))
1326                                     (std11-header-string-except
1327                                      (concat
1328                                       "^"
1329                                       (apply (function regexp-or) fields)
1330                                       ":") ""))))
1331                           (if (and (eq (mime-entity-media-type
1332                                         current-entity) 'message)
1333                                    (eq (mime-entity-media-subtype
1334                                         current-entity) 'rfc822))
1335                               nil
1336                             (if str
1337                                 (insert str)
1338                               )
1339                             t)))
1340               (setq fields (std11-collect-field-names)
1341                     current-entity (mime-entity-parent current-entity))
1342               )
1343             )
1344           (let ((rest mime-view-following-required-fields-list)
1345                 field-name ret)
1346             (while rest
1347               (setq field-name (car rest))
1348               (or (std11-field-body field-name)
1349                   (progn
1350                     (save-excursion
1351                       (set-buffer the-buf)
1352                       (setq ret
1353                             (when mime-mother-buffer
1354                               (set-buffer mime-mother-buffer)
1355                               (mime-entity-fetch-field
1356                                (get-text-property (point)
1357                                                   'mime-view-entity)
1358                                field-name))))
1359                     (if ret
1360                         (insert (concat field-name ": " ret "\n"))
1361                       )))
1362               (setq rest (cdr rest))
1363               ))
1364           (mime-decode-header-in-buffer)
1365           )
1366         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1367           (if (functionp f)
1368               (funcall f new-buf)
1369             (message
1370              (format
1371               "Sorry, following method for %s is not implemented yet."
1372               mode))
1373             ))
1374         ))))
1375
1376
1377 ;;; @@ moving
1378 ;;;
1379
1380 (defun mime-preview-move-to-upper ()
1381   "Move to upper entity.
1382 If there is no upper entity, call function `mime-preview-quit'."
1383   (interactive)
1384   (let (cinfo)
1385     (while (null (setq cinfo
1386                        (get-text-property (point) 'mime-view-entity)))
1387       (backward-char)
1388       )
1389     (let ((r (mime-entity-parent cinfo))
1390           point)
1391       (catch 'tag
1392         (while (setq point (previous-single-property-change
1393                             (point) 'mime-view-entity))
1394           (goto-char point)
1395           (when (eq r (get-text-property (point) 'mime-view-entity))
1396             (if (or (eq mime-preview-move-scroll t)
1397                     (and mime-preview-move-scroll
1398                          (>= point
1399                              (save-excursion
1400                                (move-to-window-line -1)
1401                                (forward-line (* -1 next-screen-context-lines))
1402                                (beginning-of-line)
1403                                (point)))))
1404                 (recenter next-screen-context-lines))
1405             (throw 'tag t)
1406             )
1407           )
1408         (mime-preview-quit)
1409         ))))
1410
1411 (defun mime-preview-move-to-previous ()
1412   "Move to previous entity.
1413 If there is no previous entity, it calls function registered in
1414 variable `mime-preview-over-to-previous-method-alist'."
1415   (interactive)
1416   (while (and (not (bobp))
1417               (null (get-text-property (point) 'mime-view-entity)))
1418     (backward-char)
1419     )
1420   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1421     (if (and point
1422              (>= point (point-min)))
1423         (if (get-text-property (1- point) 'mime-view-entity)
1424             (progn (goto-char point)
1425                    (if
1426                     (or (eq mime-preview-move-scroll t)
1427                         (and mime-preview-move-scroll
1428                              (<= point
1429                                 (save-excursion
1430                                   (move-to-window-line 0)
1431                                   (forward-line next-screen-context-lines)
1432                                   (end-of-line)
1433                                   (point)))))
1434                         (recenter (* -1 next-screen-context-lines))))
1435           (goto-char (1- point))
1436           (mime-preview-move-to-previous)
1437           )
1438       (let ((f (assq (mime-preview-original-major-mode)
1439                      mime-preview-over-to-previous-method-alist)))
1440         (if f
1441             (funcall (cdr f))
1442           ))
1443       )))
1444
1445 (defun mime-preview-move-to-next ()
1446   "Move to next entity.
1447 If there is no previous entity, it calls function registered in
1448 variable `mime-preview-over-to-next-method-alist'."
1449   (interactive)
1450   (while (and (not (eobp))
1451               (null (get-text-property (point) 'mime-view-entity)))
1452     (forward-char)
1453     )
1454   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1455     (if (and point
1456              (<= point (point-max)))
1457         (progn
1458           (goto-char point)
1459           (if (null (get-text-property point 'mime-view-entity))
1460               (mime-preview-move-to-next)
1461             (and
1462              (or (eq mime-preview-move-scroll t)
1463                  (and mime-preview-move-scroll
1464                       (>= point
1465                          (save-excursion
1466                            (move-to-window-line -1)
1467                            (forward-line
1468                             (* -1 next-screen-context-lines))
1469                            (beginning-of-line)
1470                            (point)))))
1471                  (recenter next-screen-context-lines))
1472             ))
1473       (let ((f (assq (mime-preview-original-major-mode)
1474                      mime-preview-over-to-next-method-alist)))
1475         (if f
1476             (funcall (cdr f))
1477           ))
1478       )))
1479
1480 (defun mime-preview-scroll-up-entity (&optional h)
1481   "Scroll up current entity.
1482 If reached to (point-max), it calls function registered in variable
1483 `mime-preview-over-to-next-method-alist'."
1484   (interactive)
1485   (if (eobp)
1486       (let ((f (assq (mime-preview-original-major-mode)
1487                      mime-preview-over-to-next-method-alist)))
1488         (if f
1489             (funcall (cdr f))
1490           ))
1491     (let ((point
1492            (or (next-single-property-change (point) 'mime-view-entity)
1493                (point-max)))
1494           (bottom (window-end (selected-window))))
1495       (if (and (not h)
1496                (> bottom point))
1497           (progn (goto-char point)
1498                  (recenter next-screen-context-lines))
1499         (condition-case nil
1500             (scroll-up h)
1501           (end-of-buffer
1502            (goto-char (point-max)))))
1503       )))
1504
1505 (defun mime-preview-scroll-down-entity (&optional h)
1506   "Scroll down current entity.
1507 If reached to (point-min), it calls function registered in variable
1508 `mime-preview-over-to-previous-method-alist'."
1509   (interactive)
1510   (if (bobp)
1511       (let ((f (assq (mime-preview-original-major-mode)
1512                      mime-preview-over-to-previous-method-alist)))
1513         (if f
1514             (funcall (cdr f))
1515           ))
1516     (let ((point
1517            (or (previous-single-property-change (point) 'mime-view-entity)
1518                (point-min)))
1519           (top (window-start (selected-window))))
1520       (if (and (not h)
1521                (< top point))
1522           (progn (goto-char point)
1523                  (recenter (* -1 next-screen-context-lines)))
1524         (condition-case nil
1525             (scroll-down h)
1526           (beginning-of-buffer
1527            (goto-char (point-min)))))
1528       )))
1529
1530 (defun mime-preview-next-line-entity (&optional lines)
1531   "Scroll up one line (or prefix LINES lines).
1532 If LINES is negative, scroll down LINES lines."
1533   (interactive "p")
1534   (mime-preview-scroll-up-entity (or lines 1))
1535   )
1536
1537 (defun mime-preview-previous-line-entity (&optional lines)
1538   "Scrroll down one line (or prefix LINES lines).
1539 If LINES is negative, scroll up LINES lines."
1540   (interactive "p")
1541   (mime-preview-scroll-down-entity (or lines 1))
1542   )
1543
1544 ;;; @@ quitting
1545 ;;;
1546
1547 (defun mime-preview-quit ()
1548   "Quit from MIME-preview buffer.
1549 It calls function registered in variable
1550 `mime-preview-quitting-method-alist'."
1551   (interactive)
1552   (let ((r (assq (mime-preview-original-major-mode)
1553                  mime-preview-quitting-method-alist)))
1554     (if r
1555         (funcall (cdr r))
1556       )))
1557
1558 (defun mime-preview-kill-buffer ()
1559   (interactive)
1560   (kill-buffer (current-buffer))
1561   )
1562
1563
1564 ;;; @ end
1565 ;;;
1566
1567 (provide 'mime-view)
1568
1569 (run-hooks 'mime-view-load-hook)
1570
1571 ;;; mime-view.el ends here