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