mime-view.el

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