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 mime-view-popup-menu
 962          (let ((menu (make-sparse-keymap mime-view-menu-title)))
 963            (nconc menu
 964                   (mapcar (function
 965                            (lambda (item)
 966                              (list (intern (nth 1 item)) 'menu-item
 967                                    (nth 1 item)(nth 2 item))
 968                              ))
 969                           mime-view-menu-list))))
 970        (defun mime-view-popup-menu (event)
 971          "Popup the menu in the MIME Viewer buffer"
 972          (interactive "@e")
 973          (let ((menu mime-view-popup-menu) events func)
 974            (setq events (x-popup-menu t menu))
 975            (and events
 976                 (setq func (lookup-key menu (apply #'vector events)))
 977                 (commandp func)
 978                 (funcall func))))
 979        (defvar mouse-button-2 [mouse-2])
 980        ))
 981
 982 (defun mime-view-define-keymap (&optional default)
 983   (let ((mime-view-mode-map (if (keymapp default)
 984                                 (copy-keymap default)
 985                               (make-sparse-keymap)
 986                               )))
 987     (define-key mime-view-mode-map
 988       "u"        (function mime-preview-move-to-upper))
 989     (define-key mime-view-mode-map
 990       "p"        (function mime-preview-move-to-previous))
 991     (define-key mime-view-mode-map
 992       "n"        (function mime-preview-move-to-next))
 993     (define-key mime-view-mode-map
 994       "\e\t"     (function mime-preview-move-to-previous))
 995     (define-key mime-view-mode-map
 996       "\t"       (function mime-preview-move-to-next))
 997     (define-key mime-view-mode-map
 998       " "        (function mime-preview-scroll-up-entity))
 999     (define-key mime-view-mode-map
1000       "\M- "     (function mime-preview-scroll-down-entity))
1001     (define-key mime-view-mode-map
1002       "\177"     (function mime-preview-scroll-down-entity))
1003     (define-key mime-view-mode-map
1004       "\C-m"     (function mime-preview-next-line-entity))
1005     (define-key mime-view-mode-map
1006       "\C-\M-m"  (function mime-preview-previous-line-entity))
1007     (define-key mime-view-mode-map
1008       "v"        (function mime-preview-play-current-entity))
1009     (define-key mime-view-mode-map
1010       "e"        (function mime-preview-extract-current-entity))
1011     (define-key mime-view-mode-map
1012       "\C-c\C-p" (function mime-preview-print-current-entity))
1013     (define-key mime-view-mode-map
1014       "a"        (function mime-preview-follow-current-entity))
1015     (define-key mime-view-mode-map
1016       "q"        (function mime-preview-quit))
1017     (define-key mime-view-mode-map
1018       "\C-c\C-x" (function mime-preview-kill-buffer))
1019     ;; (define-key mime-view-mode-map
1020     ;;   "<"        (function beginning-of-buffer))
1021     ;; (define-key mime-view-mode-map
1022     ;;   ">"        (function end-of-buffer))
1023     (define-key mime-view-mode-map
1024       "?"        (function describe-mode))
1025     (define-key mime-view-mode-map
1026       [tab] (function mime-preview-move-to-next))
1027     (define-key mime-view-mode-map
1028       [delete] (function mime-preview-scroll-down-entity))
1029     (define-key mime-view-mode-map
1030       [backspace] (function mime-preview-scroll-down-entity))
1031     (if (functionp default)
1032         (cond ((featurep 'xemacs)
1033                (set-keymap-default-binding mime-view-mode-map default)
1034                )
1035               (t
1036                (setq mime-view-mode-map
1037                      (append mime-view-mode-map (list (cons t default))))
1038                )))
1039     (if mouse-button-2
1040         (define-key mime-view-mode-map
1041           mouse-button-2 (function mime-button-dispatcher))
1042       )
1043     (cond ((featurep 'xemacs)
1044            (define-key mime-view-mode-map
1045              mouse-button-3 (function mime-view-xemacs-popup-menu))
1046            )
1047           ((>= emacs-major-version 19)
1048            (define-key mime-view-mode-map
1049              mouse-button-3 (function mime-view-popup-menu))
1050            (define-key mime-view-mode-map [menu-bar mime-view]
1051              (cons mime-view-menu-title
1052                    (make-sparse-keymap mime-view-menu-title)))
1053            (mapcar (function
1054                     (lambda (item)
1055                       (define-key mime-view-mode-map
1056                         (vector 'menu-bar 'mime-view (car item))
1057                         (cons (nth 1 item)(nth 2 item))
1058                         )
1059                       ))
1060                    (reverse mime-view-menu-list)
1061                    )
1062            ))
1063     (use-local-map mime-view-mode-map)
1064     (run-hooks 'mime-view-define-keymap-hook)
1065     ))
1066
1067 (defsubst mime-maybe-hide-echo-buffer ()
1068   "Clear mime-echo buffer and delete window for it."
1069   (let ((buf (get-buffer mime-echo-buffer-name)))
1070     (if buf
1071         (save-excursion
1072           (set-buffer buf)
1073           (erase-buffer)
1074           (let ((win (get-buffer-window buf)))
1075             (if win
1076                 (delete-window win)
1077               ))
1078           (bury-buffer buf)
1079           ))))
1080
1081 (defvar mime-view-redisplay nil)
1082
1083 ;;;###autoload
1084 (defun mime-display-message (message &optional preview-buffer
1085                                      mother default-keymap-or-function
1086                                      original-major-mode)
1087   "View MESSAGE in MIME-View mode.
1088
1089 Optional argument PREVIEW-BUFFER specifies the buffer of the
1090 presentation.  It must be either nil or a name of preview buffer.
1091
1092 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1093
1094 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1095 function.  If it is a keymap, keymap of MIME-View mode will be added
1096 to it.  If it is a function, it will be bound as default binding of
1097 keymap of MIME-View mode."
1098   (mime-maybe-hide-echo-buffer)
1099   (let ((win-conf (current-window-configuration)))
1100     (or preview-buffer
1101         (setq preview-buffer
1102               (concat "*Preview-" (mime-entity-name message) "*")))
1103     (or original-major-mode
1104         (setq original-major-mode
1105               (with-current-buffer (mime-entity-header-buffer message)
1106                 major-mode)))
1107     (let ((inhibit-read-only t))
1108       (set-buffer (get-buffer-create preview-buffer))
1109       (widen)
1110       (erase-buffer)
1111       (if mother
1112           (setq mime-mother-buffer mother)
1113         )
1114       (setq mime-preview-original-window-configuration win-conf)
1115       (setq major-mode 'mime-view-mode)
1116       (setq mode-name "MIME-View")
1117       (mime-display-entity message nil
1118                            `((entity-button . invisible)
1119                              (header . visible)
1120                              (major-mode . ,original-major-mode))
1121                            preview-buffer)
1122       (mime-view-define-keymap default-keymap-or-function)
1123       (let ((point
1124              (next-single-property-change (point-min) 'mime-view-entity)))
1125         (if point
1126             (goto-char point)
1127           (goto-char (point-min))
1128           (search-forward "\n\n" nil t)
1129           ))
1130       (run-hooks 'mime-view-mode-hook)
1131       (set-buffer-modified-p nil)
1132       (setq buffer-read-only t)
1133       preview-buffer)))
1134
1135 ;;;###autoload
1136 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1137                                    default-keymap-or-function
1138                                    representation-type)
1139   "View RAW-BUFFER in MIME-View mode.
1140 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1141 buffer.
1142 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1143 function.  If it is a keymap, keymap of MIME-View mode will be added
1144 to it.  If it is a function, it will be bound as default binding of
1145 keymap of MIME-View mode.
1146 Optional argument REPRESENTATION-TYPE is representation-type of
1147 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1148 `cooked' is used as default."
1149   (interactive)
1150   (or raw-buffer
1151       (setq raw-buffer (current-buffer)))
1152   (or representation-type
1153       (setq representation-type
1154             (save-excursion
1155               (set-buffer raw-buffer)
1156               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1157                        (assq t mime-raw-representation-type-alist)))
1158               )))
1159   (if (eq representation-type 'binary)
1160       (setq representation-type 'buffer)
1161     )
1162   (setq preview-buffer (mime-display-message
1163                         (mime-open-entity representation-type raw-buffer)
1164                         preview-buffer mother default-keymap-or-function))
1165   (or (get-buffer-window preview-buffer)
1166       (let ((r-win (get-buffer-window raw-buffer)))
1167         (if r-win
1168             (set-window-buffer r-win preview-buffer)
1169           (let ((m-win (and mother (get-buffer-window mother))))
1170             (if m-win
1171                 (set-window-buffer m-win preview-buffer)
1172               (switch-to-buffer preview-buffer)
1173               ))))))
1174
1175 (defun mime-view-mode (&optional mother ctl encoding
1176                                  raw-buffer preview-buffer
1177                                  default-keymap-or-function)
1178   "Major mode for viewing MIME message.
1179
1180 Here is a list of the standard keys for mime-view-mode.
1181
1182 key             feature
1183 ---             -------
1184
1185 u               Move to upper content
1186 p or M-TAB      Move to previous content
1187 n or TAB        Move to next content
1188 SPC             Scroll up or move to next content
1189 M-SPC or DEL    Scroll down or move to previous content
1190 RET             Move to next line
1191 M-RET           Move to previous line
1192 v               Decode current content as `play mode'
1193 e               Decode current content as `extract mode'
1194 C-c C-p         Decode current content as `print mode'
1195 a               Followup to current content.
1196 q               Quit
1197 button-2        Move to point under the mouse cursor
1198                 and decode current content as `play mode'
1199 "
1200   (interactive)
1201   (unless mime-view-redisplay
1202     (save-excursion
1203       (if raw-buffer (set-buffer raw-buffer))
1204       (let ((type
1205              (cdr
1206               (or (assq major-mode mime-raw-representation-type-alist)
1207                   (assq t mime-raw-representation-type-alist)))))
1208         (if (eq type 'binary)
1209             (setq type 'buffer)
1210           )
1211         (setq mime-message-structure (mime-open-entity type raw-buffer))
1212         (or (mime-entity-content-type mime-message-structure)
1213             (mime-entity-set-content-type-internal
1214              mime-message-structure ctl))
1215         )
1216       (or (mime-entity-encoding mime-message-structure)
1217           (mime-entity-set-encoding-internal mime-message-structure encoding))
1218       ))
1219   (mime-display-message mime-message-structure preview-buffer
1220                         mother default-keymap-or-function)
1221   )
1222
1223
1224 ;;; @@ playing
1225 ;;;
1226
1227 (autoload 'mime-preview-play-current-entity "mime-play"
1228   "Play current entity." t)
1229
1230 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1231   "Extract current entity into file (maybe).
1232 It decodes current entity to call internal or external method as
1233 \"extract\" mode.  The method is selected from variable
1234 `mime-acting-condition'."
1235   (interactive "P")
1236   (mime-preview-play-current-entity ignore-examples "extract")
1237   )
1238
1239 (defun mime-preview-print-current-entity (&optional ignore-examples)
1240   "Print current entity (maybe).
1241 It decodes current entity to call internal or external method as
1242 \"print\" mode.  The method is selected from variable
1243 `mime-acting-condition'."
1244   (interactive "P")
1245   (mime-preview-play-current-entity ignore-examples "print")
1246   )
1247
1248
1249 ;;; @@ following
1250 ;;;
1251
1252 (defun mime-preview-follow-current-entity ()
1253   "Write follow message to current entity.
1254 It calls following-method selected from variable
1255 `mime-preview-following-method-alist'."
1256   (interactive)
1257   (let (entity)
1258     (while (null (setq entity
1259                        (get-text-property (point) 'mime-view-entity)))
1260       (backward-char)
1261       )
1262     (let* ((p-beg
1263             (previous-single-property-change (point) 'mime-view-entity))
1264            p-end
1265            ph-end
1266            (entity-node-id (mime-entity-node-id entity))
1267            (len (length entity-node-id))
1268            )
1269       (cond ((null p-beg)
1270              (setq p-beg
1271                    (if (eq (next-single-property-change (point-min)
1272                                                         'mime-view-entity)
1273                            (point))
1274                        (point)
1275                      (point-min)))
1276              )
1277             ((eq (next-single-property-change p-beg 'mime-view-entity)
1278                  (point))
1279              (setq p-beg (point))
1280              ))
1281       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1282       (cond ((null p-end)
1283              (setq p-end (point-max))
1284              )
1285             ((null entity-node-id)
1286              (setq p-end (point-max))
1287              )
1288             (t
1289              (save-excursion
1290                (goto-char p-end)
1291                (catch 'tag
1292                  (let (e)
1293                    (while (setq e
1294                                 (next-single-property-change
1295                                  (point) 'mime-view-entity))
1296                      (goto-char e)
1297                      (let ((rc (mime-entity-node-id
1298                                 (get-text-property (point)
1299                                                    'mime-view-entity))))
1300                        (or (equal entity-node-id
1301                                   (nthcdr (- (length rc) len) rc))
1302                            (throw 'tag nil)
1303                            ))
1304                      (setq p-end e)
1305                      ))
1306                  (setq p-end (point-max))
1307                  ))
1308              ))
1309       (setq ph-end
1310             (previous-single-property-change p-end 'mime-view-entity-header))
1311       (if (or (null ph-end)
1312               (< ph-end p-beg))
1313           (setq ph-end p-beg)
1314         )
1315       (let* ((mode (mime-preview-original-major-mode 'recursive))
1316              (new-name
1317               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1318              new-buf
1319              (the-buf (current-buffer))
1320              fields)
1321         (save-excursion
1322           (set-buffer (setq new-buf (get-buffer-create new-name)))
1323           (erase-buffer)
1324           (insert-buffer-substring the-buf ph-end p-end)
1325           (when (= ph-end p-beg)
1326             (goto-char (point-min))
1327             (insert ?\n))
1328           (goto-char (point-min))
1329           (let ((current-entity
1330                  (if (and (eq (mime-entity-media-type entity) 'message)
1331                           (eq (mime-entity-media-subtype entity) 'rfc822))
1332                      (mime-entity-children entity)
1333                    entity))
1334                 str)
1335             (while (and current-entity
1336                         (progn
1337                           (setq str
1338                                 (with-current-buffer
1339                                     (mime-entity-header-buffer current-entity)
1340                                   (save-restriction
1341                                     (narrow-to-region
1342                                      (mime-entity-header-start-point
1343                                       current-entity)
1344                                      (mime-entity-header-end-point
1345                                       current-entity))
1346                                     (std11-header-string-except
1347                                      (concat
1348                                       "^"
1349                                       (apply (function regexp-or) fields)
1350                                       ":") ""))))
1351                           (if (and (eq (mime-entity-media-type
1352                                         current-entity) 'message)
1353                                    (eq (mime-entity-media-subtype
1354                                         current-entity) 'rfc822))
1355                               nil
1356                             (if str
1357                                 (insert str)
1358                               )
1359                             t)))
1360               (setq fields (std11-collect-field-names)
1361                     current-entity (mime-entity-parent current-entity))
1362               )
1363             )
1364           (let ((rest mime-view-following-required-fields-list)
1365                 field-name ret)
1366             (while rest
1367               (setq field-name (car rest))
1368               (or (std11-field-body field-name)
1369                   (progn
1370                     (save-excursion
1371                       (set-buffer the-buf)
1372                       (let ((entity (when mime-mother-buffer
1373                                       (set-buffer mime-mother-buffer)
1374                                       (get-text-property (point)
1375                                                          'mime-view-entity))))
1376                         (while (and entity
1377                                     (null (setq ret (mime-entity-fetch-field
1378                                                      entity field-name))))
1379                           (setq entity (mime-entity-parent entity)))))
1380                     (if ret
1381                         (insert (concat field-name ": " ret "\n"))
1382                       )))
1383               (setq rest (cdr rest))
1384               ))
1385           (mime-decode-header-in-buffer)
1386           )
1387         (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1388           (if (functionp f)
1389               (funcall f new-buf)
1390             (message
1391              (format
1392               "Sorry, following method for %s is not implemented yet."
1393               mode))
1394             ))
1395         ))))
1396
1397
1398 ;;; @@ moving
1399 ;;;
1400
1401 (defun mime-preview-move-to-upper ()
1402   "Move to upper entity.
1403 If there is no upper entity, call function `mime-preview-quit'."
1404   (interactive)
1405   (let (cinfo)
1406     (while (null (setq cinfo
1407                        (get-text-property (point) 'mime-view-entity)))
1408       (backward-char)
1409       )
1410     (let ((r (mime-entity-parent cinfo))
1411           point)
1412       (catch 'tag
1413         (while (setq point (previous-single-property-change
1414                             (point) 'mime-view-entity))
1415           (goto-char point)
1416           (when (eq r (get-text-property (point) 'mime-view-entity))
1417             (if (or (eq mime-preview-move-scroll t)
1418                     (and mime-preview-move-scroll
1419                          (>= point
1420                              (save-excursion
1421                                (move-to-window-line -1)
1422                                (forward-line (* -1 next-screen-context-lines))
1423                                (beginning-of-line)
1424                                (point)))))
1425                 (recenter next-screen-context-lines))
1426             (throw 'tag t)
1427             )
1428           )
1429         (mime-preview-quit)
1430         ))))
1431
1432 (defun mime-preview-move-to-previous ()
1433   "Move to previous entity.
1434 If there is no previous entity, it calls function registered in
1435 variable `mime-preview-over-to-previous-method-alist'."
1436   (interactive)
1437   (while (and (not (bobp))
1438               (null (get-text-property (point) 'mime-view-entity)))
1439     (backward-char)
1440     )
1441   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1442     (if (and point
1443              (>= point (point-min)))
1444         (if (get-text-property (1- point) 'mime-view-entity)
1445             (progn (goto-char point)
1446                    (if
1447                     (or (eq mime-preview-move-scroll t)
1448                         (and mime-preview-move-scroll
1449                              (<= point
1450                                 (save-excursion
1451                                   (move-to-window-line 0)
1452                                   (forward-line next-screen-context-lines)
1453                                   (end-of-line)
1454                                   (point)))))
1455                         (recenter (* -1 next-screen-context-lines))))
1456           (goto-char (1- point))
1457           (mime-preview-move-to-previous)
1458           )
1459       (let ((f (assq (mime-preview-original-major-mode)
1460                      mime-preview-over-to-previous-method-alist)))
1461         (if f
1462             (funcall (cdr f))
1463           ))
1464       )))
1465
1466 (defun mime-preview-move-to-next ()
1467   "Move to next entity.
1468 If there is no previous entity, it calls function registered in
1469 variable `mime-preview-over-to-next-method-alist'."
1470   (interactive)
1471   (while (and (not (eobp))
1472               (null (get-text-property (point) 'mime-view-entity)))
1473     (forward-char)
1474     )
1475   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1476     (if (and point
1477              (<= point (point-max)))
1478         (progn
1479           (goto-char point)
1480           (if (null (get-text-property point 'mime-view-entity))
1481               (mime-preview-move-to-next)
1482             (and
1483              (or (eq mime-preview-move-scroll t)
1484                  (and mime-preview-move-scroll
1485                       (>= point
1486                          (save-excursion
1487                            (move-to-window-line -1)
1488                            (forward-line
1489                             (* -1 next-screen-context-lines))
1490                            (beginning-of-line)
1491                            (point)))))
1492                  (recenter next-screen-context-lines))
1493             ))
1494       (let ((f (assq (mime-preview-original-major-mode)
1495                      mime-preview-over-to-next-method-alist)))
1496         (if f
1497             (funcall (cdr f))
1498           ))
1499       )))
1500
1501 (defun mime-preview-scroll-up-entity (&optional h)
1502   "Scroll up current entity.
1503 If reached to (point-max), it calls function registered in variable
1504 `mime-preview-over-to-next-method-alist'."
1505   (interactive)
1506   (if (eobp)
1507       (let ((f (assq (mime-preview-original-major-mode)
1508                      mime-preview-over-to-next-method-alist)))
1509         (if f
1510             (funcall (cdr f))
1511           ))
1512     (let ((point
1513            (or (next-single-property-change (point) 'mime-view-entity)
1514                (point-max)))
1515           (bottom (window-end (selected-window))))
1516       (if (and (not h)
1517                (> bottom point))
1518           (progn (goto-char point)
1519                  (recenter next-screen-context-lines))
1520         (condition-case nil
1521             (scroll-up h)
1522           (end-of-buffer
1523            (goto-char (point-max)))))
1524       )))
1525
1526 (defun mime-preview-scroll-down-entity (&optional h)
1527   "Scroll down current entity.
1528 If reached to (point-min), it calls function registered in variable
1529 `mime-preview-over-to-previous-method-alist'."
1530   (interactive)
1531   (if (bobp)
1532       (let ((f (assq (mime-preview-original-major-mode)
1533                      mime-preview-over-to-previous-method-alist)))
1534         (if f
1535             (funcall (cdr f))
1536           ))
1537     (let ((point
1538            (or (previous-single-property-change (point) 'mime-view-entity)
1539                (point-min)))
1540           (top (window-start (selected-window))))
1541       (if (and (not h)
1542                (< top point))
1543           (progn (goto-char point)
1544                  (recenter (* -1 next-screen-context-lines)))
1545         (condition-case nil
1546             (scroll-down h)
1547           (beginning-of-buffer
1548            (goto-char (point-min)))))
1549       )))
1550
1551 (defun mime-preview-next-line-entity (&optional lines)
1552   "Scroll up one line (or prefix LINES lines).
1553 If LINES is negative, scroll down LINES lines."
1554   (interactive "p")
1555   (mime-preview-scroll-up-entity (or lines 1))
1556   )
1557
1558 (defun mime-preview-previous-line-entity (&optional lines)
1559   "Scrroll down one line (or prefix LINES lines).
1560 If LINES is negative, scroll up LINES lines."
1561   (interactive "p")
1562   (mime-preview-scroll-down-entity (or lines 1))
1563   )
1564
1565 ;;; @@ quitting
1566 ;;;
1567
1568 (defun mime-preview-quit ()
1569   "Quit from MIME-preview buffer.
1570 It calls function registered in variable
1571 `mime-preview-quitting-method-alist'."
1572   (interactive)
1573   (let ((r (assq (mime-preview-original-major-mode)
1574                  mime-preview-quitting-method-alist)))
1575     (if r
1576         (funcall (cdr r))
1577       )))
1578
1579 (defun mime-preview-kill-buffer ()
1580   (interactive)
1581   (kill-buffer (current-buffer))
1582   )
1583
1584
1585 ;;; @ end
1586 ;;;
1587
1588 (provide 'mime-view)
1589
1590 (run-hooks 'mime-view-load-hook)
1591
1592 ;;; mime-view.el ends here