mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,96,97,98,99,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., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Code:
  29
  30 (require 'mime)
  31 (require 'semi-def)
  32 (require 'calist)
  33 (require 'alist)
  34 (require 'mime-conf)
  35
  36 (eval-when-compile (require 'static))
  37
  38
  39 ;;; @ version
  40 ;;;
  41
  42 (defconst mime-view-version
  43   (concat (mime-product-name mime-user-interface-product) " MIME-View "
  44           (mapconcat #'number-to-string
  45                      (mime-product-version mime-user-interface-product) ".")
  46           " (" (mime-product-code-name mime-user-interface-product) ")"))
  47
  48
  49 ;;; @ variables
  50 ;;;
  51
  52 (defgroup mime-view nil
  53   "MIME view mode"
  54   :group 'mime)
  55
  56 (defcustom mime-situation-examples-file "~/.mime-example"
  57   "*File name of situation-examples demonstrated by user."
  58   :group 'mime-view
  59   :type 'file)
  60
  61 (defcustom mime-preview-move-scroll nil
  62   "*Decides whether to scroll when moving to next entity.
  63 When t, scroll the buffer. Non-nil but not t means scroll when
  64 the next entity is within next-screen-context-lines from top or
  65 buttom. Nil means don't scroll at all."
  66   :group 'mime-view
  67   :type '(choice (const :tag "Off" nil)
  68                  (const :tag "On" t)
  69                  (sexp :tag "Situation" 1)))
  70
  71 (defcustom mime-view-mailcap-files
  72   (let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap")))
  73     (or (member mime-mailcap-file files)
  74         (setq files (cons mime-mailcap-file files)))
  75     files)
  76   "List of mailcap files."
  77   :group 'mime-view
  78   :type '(repeat file))
  79
  80 (defcustom mime-view-buttons-visible t
  81   "Toggle visibility of MIME buttons."
  82   :group 'mime-view
  83   :type 'boolean)
  84
  85 ;;; @ in raw-buffer (representation space)
  86 ;;;
  87
  88 (defvar mime-preview-buffer nil
  89   "MIME-preview buffer corresponding with the (raw) buffer.")
  90 (make-variable-buffer-local 'mime-preview-buffer)
  91
  92
  93 (defvar mime-raw-representation-type-alist
  94   '((mime-show-message-mode     . binary)
  95     (mime-temp-message-mode     . binary)
  96     (t                          . cooked)
  97     )
  98   "Alist of major-mode vs. representation-type of mime-raw-buffer.
  99 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
 100 major-mode or t.  t means default.  REPRESENTATION-TYPE must be
 101 `binary' or `cooked'.")
 102
 103
 104 ;;; @ in preview-buffer (presentation space)
 105 ;;;
 106
 107 (defvar mime-mother-buffer nil
 108   "Mother buffer corresponding with the (MIME-preview) buffer.
 109 If current MIME-preview buffer is generated by other buffer, such as
 110 message/partial, it is called `mother-buffer'.")
 111 (make-variable-buffer-local 'mime-mother-buffer)
 112
 113 ;; (defvar mime-raw-buffer nil
 114 ;;   "Raw buffer corresponding with the (MIME-preview) buffer.")
 115 ;; (make-variable-buffer-local 'mime-raw-buffer)
 116
 117 (defvar mime-preview-original-window-configuration nil
 118   "Window-configuration before mime-view-mode is called.")
 119 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 120
 121 (defun mime-preview-original-major-mode (&optional recursive point)
 122   "Return major-mode of original buffer.
 123 If optional argument RECURSIVE is non-nil and current buffer has
 124 mime-mother-buffer, it returns original major-mode of the
 125 mother-buffer."
 126   (if (and recursive mime-mother-buffer)
 127       (save-excursion
 128         (set-buffer mime-mother-buffer)
 129         (mime-preview-original-major-mode recursive)
 130         )
 131     (cdr (assq 'major-mode
 132                (get-text-property (or point
 133                                       (if (> (point) (buffer-size))
 134                                           (max (1- (point-max)) (point-min))
 135                                         (point)))
 136                                   'mime-view-situation)))))
 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     situation))
 215
 216 (defsubst mime-delq-null-situation (situations field
 217                                                &rest ignored-values)
 218   (let (dest)
 219     (while situations
 220       (let* ((situation (car situations))
 221              (cell (assq field situation)))
 222         (if cell
 223             (or (memq (cdr cell) ignored-values)
 224                 (setq dest (cons situation dest))
 225                 )))
 226       (setq situations (cdr situations)))
 227     dest))
 228
 229 (defun mime-compare-situation-with-example (situation example)
 230   (let ((example (copy-alist example))
 231         (match 0))
 232     (while situation
 233       (let* ((cell (car situation))
 234              (key (car cell))
 235              (ecell (assoc key example)))
 236         (when ecell
 237           (if (equal cell ecell)
 238               (setq match (1+ match))
 239             (setq example (delq ecell example))
 240             ))
 241         )
 242       (setq situation (cdr situation))
 243       )
 244     (cons match example)
 245     ))
 246
 247 (defun mime-sort-situation (situation)
 248   (sort situation
 249         #'(lambda (a b)
 250             (let ((a-t (car a))
 251                   (b-t (car b))
 252                   (order '((type . 1)
 253                            (subtype . 2)
 254                            (mode . 3)
 255                            (method . 4)
 256                            (major-mode . 5)
 257                            (disposition-type . 6)
 258                            ))
 259                   a-order b-order)
 260               (if (symbolp a-t)
 261                   (let ((ret (assq a-t order)))
 262                     (if ret
 263                         (setq a-order (cdr ret))
 264                       (setq a-order 7)
 265                       ))
 266                 (setq a-order 8)
 267                 )
 268               (if (symbolp b-t)
 269                   (let ((ret (assq b-t order)))
 270                     (if ret
 271                         (setq b-order (cdr ret))
 272                       (setq b-order 7)
 273                       ))
 274                 (setq b-order 8)
 275                 )
 276               (if (= a-order b-order)
 277                   (string< (format "%s" a-t)(format "%s" b-t))
 278                 (< a-order b-order))
 279               )))
 280   )
 281
 282 (defun mime-unify-situations (entity-situation
 283                               condition situation-examples
 284                               &optional required-name ignored-value
 285                               every-situations)
 286   (let (ret)
 287     (in-calist-package 'mime-view)
 288     (setq ret
 289           (ctree-find-calist condition entity-situation
 290                              every-situations))
 291     (if required-name
 292         (setq ret (mime-delq-null-situation ret required-name
 293                                             ignored-value t)))
 294     (or (assq 'ignore-examples entity-situation)
 295         (if (cdr ret)
 296             (let ((rest ret)
 297                   (max-score 0)
 298                   (max-escore 0)
 299                   max-examples
 300                   max-situations)
 301               (while rest
 302                 (let ((situation (car rest))
 303                       (examples situation-examples))
 304                   (while examples
 305                     (let* ((ret
 306                             (mime-compare-situation-with-example
 307                              situation (caar examples)))
 308                            (ret-score (car ret)))
 309                       (cond ((> ret-score max-score)
 310                              (setq max-score ret-score
 311                                    max-escore (cdar examples)
 312                                    max-examples (list (cdr ret))
 313                                    max-situations (list situation))
 314                              )
 315                             ((= ret-score max-score)
 316                              (cond ((> (cdar examples) max-escore)
 317                                     (setq max-escore (cdar examples)
 318                                           max-examples (list (cdr ret))
 319                                           max-situations (list situation))
 320                                     )
 321                                    ((= (cdar examples) max-escore)
 322                                     (setq max-examples
 323                                           (cons (cdr ret) max-examples))
 324                                     (or (member situation max-situations)
 325                                         (setq max-situations
 326                                               (cons situation max-situations)))
 327                                     )))))
 328                     (setq examples (cdr examples))))
 329                 (setq rest (cdr rest)))
 330               (when max-situations
 331                 (setq ret max-situations)
 332                 (while max-examples
 333                   (let* ((example (car max-examples))
 334                          (cell
 335                           (assoc example situation-examples)))
 336                     (if cell
 337                         (setcdr cell (1+ (cdr cell)))
 338                       (setq situation-examples
 339                             (cons (cons example 0)
 340                                   situation-examples))
 341                       ))
 342                   (setq max-examples (cdr max-examples))
 343                   )))))
 344     (cons ret situation-examples)
 345     ;; ret: list of situations
 346     ;; situation-examples: new examples (notoce that contents of
 347     ;;                     argument `situation-examples' has bees modified)
 348     ))
 349
 350 (defun mime-view-entity-title (entity)
 351   (or (mime-entity-read-field entity 'Content-Description)
 352       (mime-entity-read-field entity 'Subject)
 353       (mime-entity-filename entity)
 354       ""))
 355
 356 (defvar mime-preview-situation-example-list nil)
 357 (defvar mime-preview-situation-example-list-max-size 16)
 358 ;; (defvar mime-preview-situation-example-condition nil)
 359
 360 (defun mime-find-entity-preview-situation (entity
 361                                            &optional default-situation)
 362   (or (let ((ret
 363              (mime-unify-situations
 364               (append (mime-entity-situation entity)
 365                       default-situation)
 366               mime-preview-condition
 367               mime-preview-situation-example-list)))
 368         (setq mime-preview-situation-example-list
 369               (cdr ret))
 370         (caar ret))
 371       default-situation))
 372
 373
 374 (defvar mime-acting-situation-example-list nil)
 375 (defvar mime-acting-situation-example-list-max-size 16)
 376 (defvar mime-situation-examples-file-coding-system nil)
 377
 378 (defun mime-view-read-situation-examples-file (&optional file)
 379   (or file
 380       (setq file mime-situation-examples-file))
 381   (if (and file
 382            (file-readable-p file))
 383       (with-temp-buffer
 384         (insert-file-contents file)
 385         (setq mime-situation-examples-file-coding-system
 386               (static-cond
 387                ((boundp 'buffer-file-coding-system)
 388                 (symbol-value 'buffer-file-coding-system))
 389                ((boundp 'file-coding-system)
 390                 (symbol-value 'file-coding-system))
 391                (t nil))
 392               ;; (and (boundp 'buffer-file-coding-system)
 393               ;;      buffer-file-coding-system)
 394               )
 395         (condition-case error
 396             (eval-buffer)
 397           (error (message "%s is broken: %s" file (cdr error))))
 398         ;; format check
 399         (condition-case nil
 400             (let ((i 0))
 401               (while (and (> (length mime-preview-situation-example-list)
 402                              mime-preview-situation-example-list-max-size)
 403                           (< i 16))
 404                 (setq mime-preview-situation-example-list
 405                       (mime-reduce-situation-examples
 406                        mime-preview-situation-example-list))
 407                 (setq i (1+ i))))
 408           (error (setq mime-preview-situation-example-list nil)))
 409         ;; (let ((rest mime-preview-situation-example-list))
 410         ;;   (while rest
 411         ;;     (ctree-set-calist-strictly 'mime-preview-condition
 412         ;;                                (caar rest))
 413         ;;     (setq rest (cdr rest))))
 414         (condition-case nil
 415             (let ((i 0))
 416               (while (and (> (length mime-acting-situation-example-list)
 417                              mime-acting-situation-example-list-max-size)
 418                           (< i 16))
 419                 (setq mime-acting-situation-example-list
 420                       (mime-reduce-situation-examples
 421                        mime-acting-situation-example-list))
 422                 (setq i (1+ i))))
 423           (error (setq mime-acting-situation-example-list nil))))))
 424
 425 (defun mime-save-situation-examples ()
 426   (if (or mime-preview-situation-example-list
 427           mime-acting-situation-example-list)
 428       (let ((file mime-situation-examples-file)
 429             print-length print-level)
 430         (with-temp-buffer
 431           (insert ";;; " (file-name-nondirectory file) "\n")
 432           (insert "\n;; This file is generated automatically by "
 433                   mime-view-version "\n\n")
 434           (insert ";;; Code:\n\n")
 435           (if mime-preview-situation-example-list
 436               (pp `(setq mime-preview-situation-example-list
 437                          ',mime-preview-situation-example-list)
 438                   (current-buffer)))
 439           (if mime-acting-situation-example-list
 440               (pp `(setq mime-acting-situation-example-list
 441                          ',mime-acting-situation-example-list)
 442                   (current-buffer)))
 443           (insert "\n;;; "
 444                   (file-name-nondirectory file)
 445                   " ends here.\n")
 446           (static-cond
 447            ((boundp 'buffer-file-coding-system)
 448             (setq buffer-file-coding-system
 449                   mime-situation-examples-file-coding-system))
 450            ((boundp 'file-coding-system)
 451             (setq file-coding-system
 452                   mime-situation-examples-file-coding-system)))
 453           ;; (setq buffer-file-coding-system
 454           ;;       mime-situation-examples-file-coding-system)
 455           (setq buffer-file-name file)
 456           (save-buffer)))))
 457
 458 (add-hook 'kill-emacs-hook 'mime-save-situation-examples)
 459
 460 (defun mime-reduce-situation-examples (situation-examples)
 461   (let ((len (length situation-examples))
 462         i ir ic j jr jc ret
 463         dest d-i d-j
 464         (max-sim 0) sim
 465         min-det-ret det-ret
 466         min-det-org det-org
 467         min-freq freq)
 468     (setq i 0
 469           ir situation-examples)
 470     (while (< i len)
 471       (setq ic (car ir)
 472             j 0
 473             jr situation-examples)
 474       (while (< j len)
 475         (unless (= i j)
 476           (setq jc (car jr))
 477           (setq ret (mime-compare-situation-with-example (car ic)(car jc))
 478                 sim (car ret)
 479                 det-ret (+ (length (car ic))(length (car jc)))
 480                 det-org (length (cdr ret))
 481                 freq (+ (cdr ic)(cdr jc)))
 482           (cond ((< max-sim sim)
 483                  (setq max-sim sim
 484                        min-det-ret det-ret
 485                        min-det-org det-org
 486                        min-freq freq
 487                        d-i i
 488                        d-j j
 489                        dest (cons (cdr ret) freq))
 490                  )
 491                 ((= max-sim sim)
 492                  (cond ((> min-det-ret det-ret)
 493                         (setq min-det-ret det-ret
 494                               min-det-org det-org
 495                               min-freq freq
 496                               d-i i
 497                               d-j j
 498                               dest (cons (cdr ret) freq))
 499                         )
 500                        ((= min-det-ret det-ret)
 501                         (cond ((> min-det-org det-org)
 502                                (setq min-det-org det-org
 503                                      min-freq freq
 504                                      d-i i
 505                                      d-j j
 506                                      dest (cons (cdr ret) freq))
 507                                )
 508                               ((= min-det-org det-org)
 509                                (cond ((> min-freq freq)
 510                                       (setq min-freq freq
 511                                             d-i i
 512                                             d-j j
 513                                             dest (cons (cdr ret) freq))
 514                                       ))
 515                                ))
 516                         ))
 517                  ))
 518           )
 519         (setq jr (cdr jr)
 520               j (1+ j)))
 521       (setq ir (cdr ir)
 522             i (1+ i)))
 523     (if (> d-i d-j)
 524         (setq i d-i
 525               d-i d-j
 526               d-j i))
 527     (setq jr (nthcdr (1- d-j) situation-examples))
 528     (setcdr jr (cddr jr))
 529     (if (= d-i 0)
 530         (setq situation-examples
 531               (cdr situation-examples))
 532       (setq ir (nthcdr (1- d-i) situation-examples))
 533       (setcdr ir (cddr ir))
 534       )
 535     (if (setq ir (assoc (car dest) situation-examples))
 536         (progn
 537           (setcdr ir (+ (cdr ir)(cdr dest)))
 538           situation-examples)
 539       (cons dest situation-examples)
 540       ;; situation-examples may be modified.
 541       )))
 542
 543
 544 ;;; @ presentation of preview
 545 ;;;
 546
 547 ;;; @@ entity-button
 548 ;;;
 549
 550 ;;; @@@ predicate function
 551 ;;;
 552
 553 ;; (defun mime-view-entity-button-visible-p (entity)
 554 ;;   "Return non-nil if header of ENTITY is visible.
 555 ;; Please redefine this function if you want to change default setting."
 556 ;;   (let ((media-type (mime-entity-media-type entity))
 557 ;;         (media-subtype (mime-entity-media-subtype entity)))
 558 ;;     (or (not (eq media-type 'application))
 559 ;;         (and (not (eq media-subtype 'x-selection))
 560 ;;              (or (not (eq media-subtype 'octet-stream))
 561 ;;                  (let ((mother-entity (mime-entity-parent entity)))
 562 ;;                    (or (not (eq (mime-entity-media-type mother-entity)
 563 ;;                                 'multipart))
 564 ;;                        (not (eq (mime-entity-media-subtype mother-entity)
 565 ;;                                 'encrypted)))
 566 ;;                    )
 567 ;;                  )))))
 568
 569 ;;; @@@ entity button generator
 570 ;;;
 571
 572 (defun mime-view-insert-entity-button (entity)
 573   "Insert entity-button of ENTITY."
 574   (let ((entity-node-id (mime-entity-node-id entity))
 575         (params (mime-entity-parameters entity))
 576         (subject (mime-view-entity-title entity)))
 577     (mime-insert-button
 578      (let ((access-type (assoc "access-type" params))
 579            (num (or (cdr (assoc "x-part-number" params))
 580                     (if (consp entity-node-id)
 581                         (mapconcat (function
 582                                     (lambda (num)
 583                                       (format "%s" (1+ num))
 584                                       ))
 585                                    (reverse entity-node-id) ".")
 586                       "0"))
 587                 ))
 588        (cond (access-type
 589               (let ((server (assoc "server" params)))
 590                 (setq access-type (cdr access-type))
 591                 (if server
 592                     (format "%s %s ([%s] %s)"
 593                             num subject access-type (cdr server))
 594                 (let ((site (cdr (assoc "site" params)))
 595                       (dir (cdr (assoc "directory" params)))
 596                       (url (cdr (assoc "url" params)))
 597                       )
 598                   (if url
 599                       (format "%s %s ([%s] %s)"
 600                               num subject access-type url)
 601                     (format "%s %s ([%s] %s:%s)"
 602                             num subject access-type site dir))
 603                   )))
 604             )
 605            (t
 606             (let* ((charset (cdr (assoc "charset" params)))
 607                    (encoding (mime-entity-encoding entity))
 608                    (rest (format " <%s/%s%s%s>"
 609                                  (mime-entity-media-type entity)
 610                                  (mime-entity-media-subtype entity)
 611                                  (if charset
 612                                      (concat "; " charset)
 613                                    "")
 614                                  (if encoding
 615                                      (concat " (" encoding ")")
 616                                    ""))))
 617               (concat
 618                num " " subject
 619                (if (>= (+ (current-column)(length rest))(window-width))
 620                    "\n\t")
 621                rest))
 622             )))
 623      (function mime-preview-play-current-entity))
 624     ))
 625
 626
 627 ;;; @@ entity-header
 628 ;;;
 629
 630 (defvar mime-header-presentation-method-alist nil
 631   "Alist of major mode vs. corresponding header-presentation-method functions.
 632 Each element looks like (SYMBOL . FUNCTION).
 633 SYMBOL must be major mode in raw-buffer or t.  t means default.
 634 Interface of FUNCTION must be (ENTITY SITUATION).")
 635
 636 (defvar mime-view-ignored-field-list
 637   '(".*Received:" ".*Path:" ".*Id:" "^References:"
 638     "^Replied:" "^Errors-To:"
 639     "^Lines:" "^Sender:" ".*Host:" "^Xref:"
 640     "^Content-Type:" "^Precedence:"
 641     "^Status:" "^X-VM-.*:")
 642   "All fields that match this list will be hidden in MIME preview buffer.
 643 Each elements are regexp of field-name.")
 644
 645 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
 646   "All fields that match this list will be displayed in MIME preview buffer.
 647 Each elements are regexp of field-name.")
 648
 649
 650 ;;; @@ entity-body
 651 ;;;
 652
 653 ;;; @@@ predicate function
 654 ;;;
 655
 656 (in-calist-package 'mime-view)
 657
 658 (defun mime-calist::field-match-method-as-default-rule (calist
 659                                                         field-type field-value)
 660   (let ((s-field (assq field-type calist)))
 661     (cond ((null s-field)
 662            (cons (cons field-type field-value) calist)
 663            )
 664           (t calist))))
 665
 666 (define-calist-field-match-method
 667   'header #'mime-calist::field-match-method-as-default-rule)
 668
 669 (define-calist-field-match-method
 670   'body #'mime-calist::field-match-method-as-default-rule)
 671
 672 (defun mime-calist::field-match-method-ignore-case (calist
 673                                                     field-type field-value)
 674   (let ((s-field (assoc field-type calist)))
 675     (cond ((null s-field)
 676            (cons (cons field-type field-value) calist))
 677           ((eq field-value t)
 678            calist)
 679           ((string= (downcase (cdr s-field)) (downcase field-value))
 680            calist))))
 681
 682 (define-calist-field-match-method
 683   'access-type #'mime-calist::field-match-method-ignore-case)
 684
 685
 686 (defvar mime-preview-condition nil
 687   "Condition-tree about how to display entity.")
 688
 689 (ctree-set-calist-strictly
 690  'mime-preview-condition '((type . application)(subtype . octet-stream)
 691                            (encoding . nil)
 692                            (body . visible)))
 693 (ctree-set-calist-strictly
 694  'mime-preview-condition '((type . application)(subtype . octet-stream)
 695                            (encoding . "7bit")
 696                            (body . visible)))
 697 (ctree-set-calist-strictly
 698  'mime-preview-condition '((type . application)(subtype . octet-stream)
 699                            (encoding . "8bit")
 700                            (body . visible)))
 701
 702 (ctree-set-calist-strictly
 703  'mime-preview-condition '((type . application)(subtype . pgp)
 704                            (body . visible)))
 705
 706 (ctree-set-calist-strictly
 707  'mime-preview-condition '((type . application)(subtype . x-latex)
 708                            (body . visible)))
 709
 710 (ctree-set-calist-strictly
 711  'mime-preview-condition '((type . application)(subtype . x-selection)
 712                            (body . visible)))
 713
 714 (ctree-set-calist-strictly
 715  'mime-preview-condition '((type . application)(subtype . x-comment)
 716                            (body . visible)))
 717
 718 (ctree-set-calist-strictly
 719  'mime-preview-condition '((type . message)(subtype . delivery-status)
 720                            (body . visible)))
 721
 722 (ctree-set-calist-strictly
 723  'mime-preview-condition
 724  '((body . visible)
 725    (body-presentation-method . mime-display-text/plain)))
 726
 727 (ctree-set-calist-strictly
 728  'mime-preview-condition
 729  '((type . nil)
 730    (body . visible)
 731    (body-presentation-method . mime-display-text/plain)))
 732
 733 (ctree-set-calist-strictly
 734  'mime-preview-condition
 735  '((type . text)(subtype . enriched)
 736    (body . visible)
 737    (body-presentation-method . mime-display-text/enriched)))
 738
 739 (ctree-set-calist-strictly
 740  'mime-preview-condition
 741  '((type . text)(subtype . richtext)
 742    (body . visible)
 743    (body-presentation-method . mime-display-text/richtext)))
 744
 745 (autoload 'mime-display-application/x-postpet "postpet")
 746
 747 (ctree-set-calist-strictly
 748  'mime-preview-condition
 749  '((type . application)(subtype . x-postpet)
 750    (body . visible)
 751    (body-presentation-method . mime-display-application/x-postpet)))
 752
 753 (ctree-set-calist-strictly
 754  'mime-preview-condition
 755  '((type . text)(subtype . t)
 756    (body . visible)
 757    (body-presentation-method . mime-display-text/plain)))
 758
 759 (ctree-set-calist-strictly
 760  'mime-preview-condition
 761  '((type . multipart)(subtype . alternative)
 762    (body . visible)
 763    (body-presentation-method . mime-display-multipart/alternative)))
 764
 765 (ctree-set-calist-strictly
 766  'mime-preview-condition
 767  '((type . multipart)(subtype . related)
 768    (body . visible)
 769    (body-presentation-method . mime-display-multipart/related)))
 770
 771 (ctree-set-calist-strictly
 772  'mime-preview-condition
 773  '((type . multipart)(subtype . t)
 774    (body . visible)
 775    (body-presentation-method . mime-display-multipart/mixed)))
 776
 777 (ctree-set-calist-strictly
 778  'mime-preview-condition
 779  '((type . message)(subtype . partial)
 780    (body . visible)
 781    (body-presentation-method . mime-display-message/partial-button)))
 782
 783 (ctree-set-calist-strictly
 784  'mime-preview-condition
 785  '((type . message)(subtype . rfc822)
 786    (body . visible)
 787    (body-presentation-method . mime-display-multipart/mixed)
 788    (childrens-situation (header . visible)
 789                         (entity-button . invisible))))
 790
 791 (ctree-set-calist-strictly
 792  'mime-preview-condition
 793  '((type . message)(subtype . news)
 794    (body . visible)
 795    (body-presentation-method . mime-display-multipart/mixed)
 796    (childrens-situation (header . visible)
 797                         (entity-button . invisible))))
 798
 799
 800 ;;; @@@ entity presentation
 801 ;;;
 802
 803 (defun mime-display-text/plain (entity situation)
 804   (save-restriction
 805     (narrow-to-region (point-max)(point-max))
 806     (condition-case nil
 807         (mime-insert-text-content entity)
 808       (error (progn
 809                (message "Can't decode current entity.")
 810                (sit-for 1))))
 811     (run-hooks 'mime-text-decode-hook)
 812     (goto-char (point-max))
 813     (if (not (eq (char-after (1- (point))) ?\n))
 814         (insert "\n")
 815       )
 816     (mime-add-url-buttons)
 817     (run-hooks 'mime-display-text/plain-hook)
 818     ))
 819
 820 (defun mime-display-text/richtext (entity situation)
 821   (save-restriction
 822     (narrow-to-region (point-max)(point-max))
 823     (mime-insert-text-content entity)
 824     (run-hooks 'mime-text-decode-hook)
 825     (let ((beg (point-min)))
 826       (remove-text-properties beg (point-max) '(face nil))
 827       (richtext-decode beg (point-max))
 828       )))
 829
 830 (defun mime-display-text/enriched (entity situation)
 831   (save-restriction
 832     (narrow-to-region (point-max)(point-max))
 833     (mime-insert-text-content entity)
 834     (run-hooks 'mime-text-decode-hook)
 835     (let ((beg (point-min)))
 836       (remove-text-properties beg (point-max) '(face nil))
 837       (enriched-decode beg (point-max))
 838       )))
 839
 840
 841 (defvar mime-view-announcement-for-message/partial
 842   (if (and (>= emacs-major-version 19) window-system)
 843       "\
 844 \[[ This is message/partial style split message. ]]
 845 \[[ Please press `v' key in this buffer          ]]
 846 \[[ or click here by mouse button-2.             ]]"
 847     "\
 848 \[[ This is message/partial style split message. ]]
 849 \[[ Please press `v' key in this buffer.         ]]"
 850     ))
 851
 852 (defun mime-display-message/partial-button (&optional entity situation)
 853   (save-restriction
 854     (goto-char (point-max))
 855     (if (not (search-backward "\n\n" nil t))
 856         (insert "\n")
 857       )
 858     (goto-char (point-max))
 859     (narrow-to-region (point-max)(point-max))
 860     (insert mime-view-announcement-for-message/partial)
 861     (mime-add-button (point-min)(point-max)
 862                      #'mime-preview-play-current-entity)
 863     ))
 864
 865 (defun mime-display-multipart/mixed (entity situation)
 866   (let ((children (mime-entity-children entity))
 867         (original-major-mode-cell (assq 'major-mode situation))
 868         (default-situation
 869           (cdr (assq 'childrens-situation situation))))
 870     (if original-major-mode-cell
 871         (setq default-situation
 872               (cons original-major-mode-cell default-situation)))
 873     (while children
 874       (mime-display-entity (car children) nil default-situation)
 875       (setq children (cdr children))
 876       )))
 877
 878 (defcustom mime-view-type-subtype-score-alist
 879   '(((text . enriched) . 3)
 880     ((text . richtext) . 2)
 881     ((text . plain)    . 1)
 882     (t . 0))
 883   "Alist MEDIA-TYPE vs corresponding score.
 884 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 885   :group 'mime-view
 886   :type '(repeat (cons (choice :tag "Media-Type"
 887                                (cons :tag "Type/Subtype"
 888                                      (symbol :tag "Primary-type")
 889                                      (symbol :tag "Subtype"))
 890                                (symbol :tag "Type")
 891                                (const :tag "Default" t))
 892                        integer)))
 893
 894 (defun mime-display-multipart/alternative (entity situation)
 895   (let* ((children (mime-entity-children entity))
 896          (original-major-mode-cell (assq 'major-mode situation))
 897          (default-situation
 898            (cdr (assq 'childrens-situation situation)))
 899          (i 0)
 900          (p 0)
 901          (max-score 0)
 902          situations)
 903     (if original-major-mode-cell
 904         (setq default-situation
 905               (cons original-major-mode-cell default-situation)))
 906     (setq situations
 907           (mapcar (function
 908                    (lambda (child)
 909                      (let ((situation
 910                             (mime-find-entity-preview-situation
 911                              child default-situation)))
 912                        (if (cdr (assq 'body-presentation-method situation))
 913                            (let ((score
 914                                   (cdr
 915                                    (or (assoc
 916                                         (cons
 917                                          (cdr (assq 'type situation))
 918                                          (cdr (assq 'subtype situation)))
 919                                         mime-view-type-subtype-score-alist)
 920                                        (assq
 921                                         (cdr (assq 'type situation))
 922                                         mime-view-type-subtype-score-alist)
 923                                        (assq
 924                                         t
 925                                         mime-view-type-subtype-score-alist)
 926                                        ))))
 927                              (if (> score max-score)
 928                                  (setq p i
 929                                        max-score score)
 930                                )))
 931                        (setq i (1+ i))
 932                        situation)
 933                      ))
 934                   children))
 935     (setq i 0)
 936     (while children
 937       (let ((child (car children))
 938             (situation (car situations)))
 939         (mime-display-entity child (if (= i p)
 940                                        situation
 941                                      (put-alist 'body 'invisible
 942                                                 (copy-alist situation)))))
 943       (setq children (cdr children)
 944             situations (cdr situations)
 945             i (1+ i)))))
 946
 947 (defun mime-display-multipart/related (entity situation)
 948   (let* ((param-start (mime-parse-msg-id
 949                        (std11-lexical-analyze
 950                         (cdr (assoc "start"
 951                                     (mime-content-type-parameters
 952                                      (mime-entity-content-type entity)))))))
 953          (start (or (and param-start (mime-find-entity-from-content-id
 954                                       param-start
 955                                       entity))
 956                     (car (mime-entity-children entity))))
 957          (original-major-mode-cell (assq 'major-mode situation))
 958          (default-situation (cdr (assq 'childrens-situation situation))))
 959     (when start
 960       (if original-major-mode-cell
 961           (setq default-situation
 962                 (cons original-major-mode-cell default-situation)))
 963       (mime-display-entity start nil default-situation))))
 964
 965 ;;; @ acting-condition
 966 ;;;
 967
 968 (defvar mime-acting-condition nil
 969   "Condition-tree about how to process entity.")
 970
 971 (defun mime-view-read-mailcap-files (&optional files)
 972   (or files
 973       (setq files mime-view-mailcap-files))
 974   (let (entries file)
 975     (while files
 976       (setq file (car files))
 977       (if (file-readable-p file)
 978           (setq entries (append entries (mime-parse-mailcap-file file))))
 979       (setq files (cdr files)))
 980     (while entries
 981       (let ((entry (car entries))
 982             view print shared)
 983         (while entry
 984           (let* ((field (car entry))
 985                  (field-type (car field)))
 986             (cond ((eq field-type 'view)  (setq view field))
 987                   ((eq field-type 'print) (setq print field))
 988                   ((memq field-type '(compose composetyped edit)))
 989                   (t (setq shared (cons field shared))))
 990             )
 991           (setq entry (cdr entry)))
 992         (setq shared (nreverse shared))
 993         (ctree-set-calist-with-default
 994          'mime-acting-condition
 995          (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 996         (if print
 997             (ctree-set-calist-with-default
 998              'mime-acting-condition
 999              (append shared
1000                      (list '(mode . "print")(cons 'method (cdr view)))))))
1001       (setq entries (cdr entries)))))
1002
1003 (mime-view-read-mailcap-files)
1004
1005 (ctree-set-calist-strictly
1006  'mime-acting-condition
1007  '((type . application)(subtype . octet-stream)
1008    (mode . "play")
1009    (method . mime-detect-content)
1010    ))
1011
1012 (ctree-set-calist-with-default
1013  'mime-acting-condition
1014  '((mode . "extract")
1015    (method . mime-save-content)))
1016
1017 (ctree-set-calist-strictly
1018  'mime-acting-condition
1019  '((type . text)(subtype . x-rot13-47)(mode . "play")
1020    (method . mime-view-caesar)
1021    ))
1022 (ctree-set-calist-strictly
1023  'mime-acting-condition
1024  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
1025    (method . mime-view-caesar)
1026    ))
1027
1028 (ctree-set-calist-strictly
1029  'mime-acting-condition
1030  '((type . message)(subtype . rfc822)(mode . "play")
1031    (method . mime-view-message/rfc822)
1032    ))
1033 (ctree-set-calist-strictly
1034  'mime-acting-condition
1035  '((type . message)(subtype . partial)(mode . "play")
1036    (method . mime-store-message/partial-piece)
1037    ))
1038
1039 (ctree-set-calist-strictly
1040  'mime-acting-condition
1041  '((type . message)(subtype . external-body)
1042    ("access-type" . "anon-ftp")
1043    (method . mime-view-message/external-anon-ftp)
1044    ))
1045
1046 (ctree-set-calist-strictly
1047  'mime-acting-condition
1048  '((type . message)(subtype . external-body)
1049    ("access-type" . "url")
1050    (method . mime-view-message/external-url)
1051    ))
1052
1053 (ctree-set-calist-strictly
1054  'mime-acting-condition
1055  '((type . application)(subtype . octet-stream)
1056    (method . mime-save-content)
1057    ))
1058
1059
1060 ;;; @ quitting method
1061 ;;;
1062
1063 (defvar mime-preview-quitting-method-alist
1064   '((mime-show-message-mode
1065      . mime-preview-quitting-method-for-mime-show-message-mode))
1066   "Alist of major-mode vs. quitting-method of mime-view.")
1067
1068 (defvar mime-preview-over-to-previous-method-alist nil
1069   "Alist of major-mode vs. over-to-previous-method of mime-view.")
1070
1071 (defvar mime-preview-over-to-next-method-alist nil
1072   "Alist of major-mode vs. over-to-next-method of mime-view.")
1073
1074
1075 ;;; @ following method
1076 ;;;
1077
1078 (defvar mime-preview-following-method-alist nil
1079   "Alist of major-mode vs. following-method of mime-view.")
1080
1081 (defvar mime-view-following-required-fields-list
1082   '("From"))
1083
1084
1085 ;;; @ buffer setup
1086 ;;;
1087
1088 (defun mime-display-entity (entity &optional situation
1089                                    default-situation preview-buffer)
1090   (or preview-buffer
1091       (setq preview-buffer (current-buffer)))
1092   (let* (e nb ne nhb nbb)
1093     (in-calist-package 'mime-view)
1094     (or situation
1095         (setq situation
1096               (mime-find-entity-preview-situation entity default-situation)))
1097     (let ((button-is-invisible
1098            (or mime-view-buttons-visible
1099                (eq (cdr (or (assq '*entity-button situation)
1100                             (assq 'entity-button situation)))
1101                    'invisible)))
1102           (header-is-visible
1103            (eq (cdr (or (assq '*header situation)
1104                         (assq 'header situation)))
1105                'visible))
1106           (body-is-visible
1107            (eq (cdr (or (assq '*body situation)
1108                         (assq 'body situation)))
1109                'visible))
1110           (children (mime-entity-children entity)))
1111       (set-buffer preview-buffer)
1112       (setq nb (point))
1113       (narrow-to-region nb nb)
1114       (or button-is-invisible
1115           ;; (if (mime-view-entity-button-visible-p entity)
1116           (mime-view-insert-entity-button entity)
1117           ;;   )
1118           )
1119       (if header-is-visible
1120           (let ((header-presentation-method
1121                  (or (cdr (assq 'header-presentation-method situation))
1122                      (cdr (assq (cdr (assq 'major-mode situation))
1123                                 mime-header-presentation-method-alist)))))
1124             (setq nhb (point))
1125             (if header-presentation-method
1126                 (funcall header-presentation-method entity situation)
1127               (mime-insert-header entity
1128                                   mime-view-ignored-field-list
1129                                   mime-view-visible-field-list))
1130             (run-hooks 'mime-display-header-hook)
1131             (put-text-property nhb (point-max) 'mime-view-entity-header entity)
1132             (goto-char (point-max))
1133             (insert "\n")))
1134       (setq nbb (point))
1135       (unless children
1136         (if body-is-visible
1137             (let ((body-presentation-method
1138                    (cdr (assq 'body-presentation-method situation))))
1139               (if (functionp body-presentation-method)
1140                   (funcall body-presentation-method entity situation)
1141                 (mime-display-text/plain entity situation)))
1142           (unless header-is-visible
1143             (goto-char (point-max))
1144             (insert "\n"))
1145           ))
1146       (setq ne (point-max))
1147       (widen)
1148       (put-text-property nb ne 'mime-view-entity entity)
1149       (put-text-property nb ne 'mime-view-situation situation)
1150       (put-text-property nbb ne 'mime-view-entity-body entity)
1151       (goto-char ne)
1152       (if (and children body-is-visible)
1153           (let ((body-presentation-method
1154                  (cdr (assq 'body-presentation-method situation))))
1155             (if (functionp body-presentation-method)
1156                 (funcall body-presentation-method entity situation)
1157               (mime-display-multipart/mixed entity situation))))
1158       )))
1159
1160
1161 ;;; @ MIME viewer mode
1162 ;;;
1163
1164 (defconst mime-view-menu-title "MIME-View")
1165 (defconst mime-view-menu-list
1166   '((up          "Move to upper entity"    mime-preview-move-to-upper)
1167     (previous    "Move to previous entity" mime-preview-move-to-previous)
1168     (next        "Move to next entity"     mime-preview-move-to-next)
1169     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
1170     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
1171     (play        "Play current entity"     mime-preview-play-current-entity)
1172     (extract     "Extract current entity"  mime-preview-extract-current-entity)
1173     (print       "Print current entity"    mime-preview-print-current-entity)
1174     )
1175   "Menu for MIME Viewer")
1176
1177 (cond ((featurep 'xemacs)
1178        (defvar mime-view-xemacs-popup-menu
1179          (cons mime-view-menu-title
1180                (mapcar (function
1181                         (lambda (item)
1182                           (vector (nth 1 item)(nth 2 item) t)
1183                           ))
1184                        mime-view-menu-list)))
1185        (defun mime-view-xemacs-popup-menu (event)
1186          "Popup the menu in the MIME Viewer buffer"
1187          (interactive "e")
1188          (select-window (event-window event))
1189          (set-buffer (event-buffer event))
1190          (popup-menu 'mime-view-xemacs-popup-menu))
1191        (defvar mouse-button-2 'button2)
1192        (defvar mouse-button-3 'button3)
1193        )
1194       (t
1195        (defvar mime-view-popup-menu
1196          (let ((menu (make-sparse-keymap mime-view-menu-title)))
1197            (nconc menu
1198                   (mapcar (function
1199                            (lambda (item)
1200                              (list (intern (nth 1 item)) 'menu-item
1201                                    (nth 1 item)(nth 2 item))
1202                              ))
1203                           mime-view-menu-list))))
1204        (defun mime-view-popup-menu (event)
1205          "Popup the menu in the MIME Viewer buffer"
1206          (interactive "@e")
1207          (let ((menu mime-view-popup-menu) events func)
1208            (setq events (x-popup-menu t menu))
1209            (and events
1210                 (setq func (lookup-key menu (apply #'vector events)))
1211                 (commandp func)
1212                 (funcall func))))
1213        (defvar mouse-button-2 [mouse-2])
1214        (defvar mouse-button-3 [mouse-3])
1215        ))
1216
1217 (defun mime-view-define-keymap (&optional default)
1218   (let ((mime-view-mode-map (if (keymapp default)
1219                                 (copy-keymap default)
1220                               (make-sparse-keymap))))
1221     (define-key mime-view-mode-map
1222       "u"        (function mime-preview-move-to-upper))
1223     (define-key mime-view-mode-map
1224       "p"        (function mime-preview-move-to-previous))
1225     (define-key mime-view-mode-map
1226       "n"        (function mime-preview-move-to-next))
1227     (define-key mime-view-mode-map
1228       "\e\t"     (function mime-preview-move-to-previous))
1229     (define-key mime-view-mode-map
1230       "\t"       (function mime-preview-move-to-next))
1231     (define-key mime-view-mode-map
1232       " "        (function mime-preview-scroll-up-entity))
1233     (define-key mime-view-mode-map
1234       "\M- "     (function mime-preview-scroll-down-entity))
1235     (define-key mime-view-mode-map
1236       "\177"     (function mime-preview-scroll-down-entity))
1237     (define-key mime-view-mode-map
1238       "\C-m"     (function mime-preview-next-line-entity))
1239     (define-key mime-view-mode-map
1240       "\C-\M-m"  (function mime-preview-previous-line-entity))
1241     (define-key mime-view-mode-map
1242       "v"        (function mime-preview-play-current-entity))
1243     (define-key mime-view-mode-map
1244       "e"        (function mime-preview-extract-current-entity))
1245     (define-key mime-view-mode-map
1246       "\C-c\C-p" (function mime-preview-print-current-entity))
1247
1248     (define-key mime-view-mode-map
1249       "\C-c\C-t\C-f" (function mime-preview-toggle-header))
1250     (define-key mime-view-mode-map
1251       "\C-c\C-th" (function mime-preview-toggle-header))
1252     (define-key mime-view-mode-map
1253       "\C-c\C-t\C-c" (function mime-preview-toggle-content))
1254
1255     (define-key mime-view-mode-map
1256       "\C-c\C-v\C-f" (function mime-preview-show-header))
1257     (define-key mime-view-mode-map
1258       "\C-c\C-vh" (function mime-preview-show-header))
1259     (define-key mime-view-mode-map
1260       "\C-c\C-v\C-c" (function mime-preview-show-content))
1261
1262     (define-key mime-view-mode-map
1263       "\C-c\C-d\C-f" (function mime-preview-hide-header))
1264     (define-key mime-view-mode-map
1265       "\C-c\C-dh" (function mime-preview-hide-header))
1266     (define-key mime-view-mode-map
1267       "\C-c\C-d\C-c" (function mime-preview-hide-content))
1268
1269     (define-key mime-view-mode-map
1270       "a"        (function mime-preview-follow-current-entity))
1271     (define-key mime-view-mode-map
1272       "q"        (function mime-preview-quit))
1273     (define-key mime-view-mode-map
1274       "\C-c\C-x" (function mime-preview-kill-buffer))
1275     ;; (define-key mime-view-mode-map
1276     ;;   "<"        (function beginning-of-buffer))
1277     ;; (define-key mime-view-mode-map
1278     ;;   ">"        (function end-of-buffer))
1279     (define-key mime-view-mode-map
1280       "?"        (function describe-mode))
1281     (define-key mime-view-mode-map
1282       [tab] (function mime-preview-move-to-next))
1283     (define-key mime-view-mode-map
1284       [delete] (function mime-preview-scroll-down-entity))
1285     (define-key mime-view-mode-map
1286       [backspace] (function mime-preview-scroll-down-entity))
1287     (if (functionp default)
1288         (cond ((featurep 'xemacs)
1289                (set-keymap-default-binding mime-view-mode-map default)
1290                )
1291               (t
1292                (setq mime-view-mode-map
1293                      (append mime-view-mode-map (list (cons t default))))
1294                )))
1295     (if mouse-button-2
1296         (define-key mime-view-mode-map
1297           mouse-button-2 (function mime-button-dispatcher))
1298       )
1299     (cond ((featurep 'xemacs)
1300            (define-key mime-view-mode-map
1301              mouse-button-3 (function mime-view-xemacs-popup-menu))
1302            )
1303           ((>= emacs-major-version 19)
1304            (define-key mime-view-mode-map
1305              mouse-button-3 (function mime-view-popup-menu))
1306            (define-key mime-view-mode-map [menu-bar mime-view]
1307              (cons mime-view-menu-title
1308                    (make-sparse-keymap mime-view-menu-title)))
1309            (mapcar (function
1310                     (lambda (item)
1311                       (define-key mime-view-mode-map
1312                         (vector 'menu-bar 'mime-view (car item))
1313                         (cons (nth 1 item)(nth 2 item)))
1314                       ))
1315                    (reverse mime-view-menu-list))
1316            ))
1317     ;; (run-hooks 'mime-view-define-keymap-hook)
1318     mime-view-mode-map))
1319
1320 (defvar mime-view-mode-default-map (mime-view-define-keymap))
1321
1322
1323 (defsubst mime-maybe-hide-echo-buffer ()
1324   "Clear mime-echo buffer and delete window for it."
1325   (let ((buf (get-buffer mime-echo-buffer-name)))
1326     (if buf
1327         (save-excursion
1328           (set-buffer buf)
1329           (erase-buffer)
1330           (let ((win (get-buffer-window buf)))
1331             (if win
1332                 (delete-window win)
1333               ))
1334           (bury-buffer buf)
1335           ))))
1336
1337 (defvar mime-view-redisplay nil)
1338
1339 ;;;###autoload
1340 (defun mime-display-message (message &optional preview-buffer
1341                                      mother default-keymap-or-function
1342                                      original-major-mode keymap)
1343   "View MESSAGE in MIME-View mode.
1344
1345 Optional argument PREVIEW-BUFFER specifies the buffer of the
1346 presentation.  It must be either nil or a name of preview buffer.
1347
1348 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1349
1350 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1351 function.  If it is a keymap, keymap of MIME-View mode will be added
1352 to it.  If it is a function, it will be bound as default binding of
1353 keymap of MIME-View mode.
1354
1355 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
1356 buffer of MESSAGE.  If it is nil, current `major-mode' is used.
1357
1358 Optional argument KEYMAP is keymap of MIME-View mode.  If it is
1359 non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored.  If it is nil,
1360 `mime-view-mode-default-map' is used."
1361   (mime-maybe-hide-echo-buffer)
1362   (let ((win-conf (current-window-configuration)))
1363     (or preview-buffer
1364         (setq preview-buffer
1365               (concat "*Preview-" (mime-entity-name message) "*")))
1366     (or original-major-mode
1367         (setq original-major-mode major-mode))
1368     (let ((inhibit-read-only t))
1369       (set-buffer (get-buffer-create preview-buffer))
1370       (widen)
1371       (erase-buffer)
1372       (if mother
1373           (setq mime-mother-buffer mother))
1374       (setq mime-preview-original-window-configuration win-conf)
1375       (setq major-mode 'mime-view-mode)
1376       (setq mode-name "MIME-View")
1377       (mime-display-entity message nil
1378                            `((entity-button . invisible)
1379                              (header . visible)
1380                              (major-mode . ,original-major-mode))
1381                            preview-buffer)
1382       (use-local-map
1383        (or keymap
1384            (if default-keymap-or-function
1385                (mime-view-define-keymap default-keymap-or-function)
1386              mime-view-mode-default-map)))
1387       (let ((point
1388              (next-single-property-change (point-min) 'mime-view-entity)))
1389         (if point
1390             (goto-char point)
1391           (goto-char (point-min))
1392           (search-forward "\n\n" nil t)))
1393       (run-hooks 'mime-view-mode-hook)
1394       (set-buffer-modified-p nil)
1395       (setq buffer-read-only t)
1396       preview-buffer)))
1397
1398 ;;;###autoload
1399 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1400                                    default-keymap-or-function
1401                                    representation-type)
1402   "View RAW-BUFFER in MIME-View mode.
1403 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1404 buffer.
1405 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1406 function.  If it is a keymap, keymap of MIME-View mode will be added
1407 to it.  If it is a function, it will be bound as default binding of
1408 keymap of MIME-View mode.
1409 Optional argument REPRESENTATION-TYPE is representation-type of
1410 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1411 `cooked' is used as default."
1412   (interactive)
1413   (or raw-buffer
1414       (setq raw-buffer (current-buffer)))
1415   (or representation-type
1416       (setq representation-type
1417             (save-excursion
1418               (set-buffer raw-buffer)
1419               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1420                        (assq t mime-raw-representation-type-alist)))
1421               )))
1422   (if (eq representation-type 'binary)
1423       (setq representation-type 'buffer)
1424     )
1425   (setq preview-buffer (mime-display-message
1426                         (mime-open-entity representation-type raw-buffer)
1427                         preview-buffer mother default-keymap-or-function))
1428   (or (get-buffer-window preview-buffer)
1429       (let ((r-win (get-buffer-window raw-buffer)))
1430         (if r-win
1431             (set-window-buffer r-win preview-buffer)
1432           (let ((m-win (and mother (get-buffer-window mother))))
1433             (if m-win
1434                 (set-window-buffer m-win preview-buffer)
1435               (switch-to-buffer preview-buffer)
1436               ))))))
1437
1438 (defun mime-view-mode (&optional mother ctl encoding
1439                                  raw-buffer preview-buffer
1440                                  default-keymap-or-function)
1441   "Major mode for viewing MIME message.
1442
1443 Here is a list of the standard keys for mime-view-mode.
1444
1445 key             feature
1446 ---             -------
1447
1448 u               Move to upper content
1449 p or M-TAB      Move to previous content
1450 n or TAB        Move to next content
1451 SPC             Scroll up or move to next content
1452 M-SPC or DEL    Scroll down or move to previous content
1453 RET             Move to next line
1454 M-RET           Move to previous line
1455 v               Decode current content as `play mode'
1456 e               Decode current content as `extract mode'
1457 C-c C-p         Decode current content as `print mode'
1458 a               Followup to current content.
1459 q               Quit
1460 button-2        Move to point under the mouse cursor
1461                 and decode current content as `play mode'
1462 "
1463   (interactive)
1464   (unless mime-view-redisplay
1465     (save-excursion
1466       (if raw-buffer (set-buffer raw-buffer))
1467       (let ((type
1468              (cdr
1469               (or (assq major-mode mime-raw-representation-type-alist)
1470                   (assq t mime-raw-representation-type-alist)))))
1471         (if (eq type 'binary)
1472             (setq type 'buffer)
1473           )
1474         (setq mime-message-structure (mime-open-entity type raw-buffer))
1475         (or (mime-entity-content-type mime-message-structure)
1476             (mime-entity-set-content-type mime-message-structure ctl))
1477         )
1478       (or (mime-entity-encoding mime-message-structure)
1479           (mime-entity-set-encoding mime-message-structure encoding))
1480       ))
1481   (mime-display-message mime-message-structure preview-buffer
1482                         mother default-keymap-or-function)
1483   )
1484
1485
1486 ;;; @@ utility
1487 ;;;
1488
1489 (defun mime-preview-find-boundary-info (&optional with-children)
1490   "Return boundary information of current part.
1491 If WITH-CHILDREN, refer boundary surrounding current part and its branches."
1492   (let (entity
1493         p-beg p-end
1494         entity-node-id len)
1495     (while (and
1496             (null (setq entity
1497                         (get-text-property (point) 'mime-view-entity)))
1498             (> (point) (point-min)))
1499       (backward-char))
1500     (setq p-beg (previous-single-property-change (point) 'mime-view-entity))
1501     (setq entity-node-id (and entity (mime-entity-node-id entity)))
1502     (setq len (length entity-node-id))
1503     (cond ((null p-beg)
1504            (setq p-beg
1505                  (if (eq (next-single-property-change (point-min)
1506                                                       'mime-view-entity)
1507                          (point))
1508                      (point)
1509                    (point-min)))
1510            )
1511           ((eq (next-single-property-change p-beg 'mime-view-entity)
1512                (point))
1513            (setq p-beg (point))
1514            ))
1515     (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1516     (cond ((null p-end)
1517            (setq p-end (point-max))
1518            )
1519           ((null entity-node-id)
1520            (setq p-end (point-max))
1521            )
1522           (with-children
1523            (save-excursion
1524              (catch 'tag
1525                (let (e i)
1526                  (while (setq e
1527                               (next-single-property-change
1528                                (point) 'mime-view-entity))
1529                    (goto-char e)
1530                    (let ((rc (mime-entity-node-id
1531                               (get-text-property (point)
1532                                                  'mime-view-entity))))
1533                      (or (and (>= (setq i (- (length rc) len)) 0)
1534                               (equal entity-node-id (nthcdr i rc)))
1535                          (throw 'tag nil)))
1536                    (setq p-end (or (next-single-property-change
1537                                     (point) 'mime-view-entity)
1538                                    (point-max)))))
1539                (setq p-end (point-max))))
1540            ))
1541     (vector p-beg p-end entity)))
1542
1543
1544 ;;; @@ playing
1545 ;;;
1546
1547 (autoload 'mime-preview-play-current-entity "mime-play"
1548   "Play current entity." t)
1549
1550 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1551   "Extract current entity into file (maybe).
1552 It decodes current entity to call internal or external method as
1553 \"extract\" mode.  The method is selected from variable
1554 `mime-acting-condition'."
1555   (interactive "P")
1556   (mime-preview-play-current-entity ignore-examples "extract")
1557   )
1558
1559 (defun mime-preview-print-current-entity (&optional ignore-examples)
1560   "Print current entity (maybe).
1561 It decodes current entity to call internal or external method as
1562 \"print\" mode.  The method is selected from variable
1563 `mime-acting-condition'."
1564   (interactive "P")
1565   (mime-preview-play-current-entity ignore-examples "print")
1566   )
1567
1568
1569 ;;; @@ following
1570 ;;;
1571
1572 (defun mime-preview-follow-current-entity ()
1573   "Write follow message to current entity.
1574 It calls following-method selected from variable
1575 `mime-preview-following-method-alist'."
1576   (interactive)
1577   (let* ((boundary-info (mime-preview-find-boundary-info t))
1578          (p-beg (aref boundary-info 0))
1579          (p-end (aref boundary-info 1))
1580          (entity (aref boundary-info 2))
1581          pb-beg)
1582     (if (or (get-text-property p-beg 'mime-view-entity-body)
1583             (null entity))
1584         (setq pb-beg p-beg)
1585       (setq pb-beg
1586             (next-single-property-change
1587              p-beg 'mime-view-entity-body nil
1588              (or (next-single-property-change p-beg 'mime-view-entity)
1589                  p-end))))
1590     (let* ((mode (mime-preview-original-major-mode 'recursive))
1591            (entity-node-id (and entity (mime-entity-node-id entity)))
1592            (new-name
1593             (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1594            new-buf
1595            (the-buf (current-buffer))
1596            fields)
1597       (save-excursion
1598         (set-buffer (setq new-buf (get-buffer-create new-name)))
1599         (erase-buffer)
1600         (insert ?\n)
1601         (insert-buffer-substring the-buf pb-beg p-end)
1602         (goto-char (point-min))
1603         (let ((current-entity
1604                (if (and entity
1605                         (eq (mime-entity-media-type entity) 'message)
1606                         (eq (mime-entity-media-subtype entity) 'rfc822))
1607                    (car (mime-entity-children entity))
1608                  entity)))
1609           (while (and current-entity
1610                       (if (and (eq (mime-entity-media-type
1611                                     current-entity) 'message)
1612                                (eq (mime-entity-media-subtype
1613                                     current-entity) 'rfc822))
1614                           nil
1615                         (mime-insert-header current-entity fields)
1616                         t))
1617             (setq fields (std11-collect-field-names)
1618                   current-entity (mime-entity-parent current-entity))
1619             ))
1620         (let ((rest mime-view-following-required-fields-list)
1621               field-name ret)
1622           (while rest
1623             (setq field-name (car rest))
1624             (or (std11-field-body field-name)
1625                 (progn
1626                   (save-excursion
1627                     (set-buffer the-buf)
1628                     (let ((entity (when mime-mother-buffer
1629                                     (set-buffer mime-mother-buffer)
1630                                     (get-text-property (point)
1631                                                        'mime-view-entity))))
1632                       (while (and entity
1633                                   (null (setq ret (mime-entity-fetch-field
1634                                                    entity field-name))))
1635                         (setq entity (mime-entity-parent entity)))))
1636                   (if ret
1637                       (insert (concat field-name ": " ret "\n"))
1638                     )))
1639             (setq rest (cdr rest))
1640             ))
1641         )
1642       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1643         (if (functionp f)
1644             (funcall f new-buf)
1645           (message
1646            "Sorry, following method for %s is not implemented yet."
1647            mode)
1648           ))
1649       )))
1650
1651
1652 ;;; @@ moving
1653 ;;;
1654
1655 (defun mime-preview-move-to-upper ()
1656   "Move to upper entity.
1657 If there is no upper entity, call function `mime-preview-quit'."
1658   (interactive)
1659   (let (cinfo)
1660     (while (null (setq cinfo
1661                        (get-text-property (point) 'mime-view-entity)))
1662       (backward-char)
1663       )
1664     (let ((r (mime-entity-parent cinfo))
1665           point)
1666       (catch 'tag
1667         (while (setq point (previous-single-property-change
1668                             (point) 'mime-view-entity))
1669           (goto-char point)
1670           (when (eq r (get-text-property (point) 'mime-view-entity))
1671             (if (or (eq mime-preview-move-scroll t)
1672                     (and mime-preview-move-scroll
1673                          (>= point
1674                              (save-excursion
1675                                (move-to-window-line -1)
1676                                (forward-line (* -1 next-screen-context-lines))
1677                                (beginning-of-line)
1678                                (point)))))
1679                 (recenter next-screen-context-lines))
1680             (throw 'tag t)
1681             )
1682           )
1683         (mime-preview-quit)
1684         ))))
1685
1686 (defun mime-preview-move-to-previous ()
1687   "Move to previous entity.
1688 If there is no previous entity, it calls function registered in
1689 variable `mime-preview-over-to-previous-method-alist'."
1690   (interactive)
1691   (while (and (not (bobp))
1692               (null (get-text-property (point) 'mime-view-entity)))
1693     (backward-char)
1694     )
1695   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1696     (if (and point
1697              (>= point (point-min)))
1698         (if (get-text-property (1- point) 'mime-view-entity)
1699             (progn (goto-char point)
1700                    (if
1701                     (or (eq mime-preview-move-scroll t)
1702                         (and mime-preview-move-scroll
1703                              (<= point
1704                                 (save-excursion
1705                                   (move-to-window-line 0)
1706                                   (forward-line next-screen-context-lines)
1707                                   (end-of-line)
1708                                   (point)))))
1709                         (recenter (* -1 next-screen-context-lines))))
1710           (goto-char (1- point))
1711           (mime-preview-move-to-previous)
1712           )
1713       (let ((f (assq (mime-preview-original-major-mode)
1714                      mime-preview-over-to-previous-method-alist)))
1715         (if f
1716             (funcall (cdr f))
1717           ))
1718       )))
1719
1720 (defun mime-preview-move-to-next ()
1721   "Move to next entity.
1722 If there is no previous entity, it calls function registered in
1723 variable `mime-preview-over-to-next-method-alist'."
1724   (interactive)
1725   (while (and (not (eobp))
1726               (null (get-text-property (point) 'mime-view-entity)))
1727     (forward-char)
1728     )
1729   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1730     (if (and point
1731              (<= point (point-max)))
1732         (progn
1733           (goto-char point)
1734           (if (null (get-text-property point 'mime-view-entity))
1735               (mime-preview-move-to-next)
1736             (and
1737              (or (eq mime-preview-move-scroll t)
1738                  (and mime-preview-move-scroll
1739                       (>= point
1740                          (save-excursion
1741                            (move-to-window-line -1)
1742                            (forward-line
1743                             (* -1 next-screen-context-lines))
1744                            (beginning-of-line)
1745                            (point)))))
1746                  (recenter next-screen-context-lines))
1747             ))
1748       (let ((f (assq (mime-preview-original-major-mode)
1749                      mime-preview-over-to-next-method-alist)))
1750         (if f
1751             (funcall (cdr f))
1752           ))
1753       )))
1754
1755 (defun mime-preview-scroll-up-entity (&optional h)
1756   "Scroll up current entity.
1757 If reached to (point-max), it calls function registered in variable
1758 `mime-preview-over-to-next-method-alist'."
1759   (interactive)
1760   (if (eobp)
1761       (let ((f (assq (mime-preview-original-major-mode)
1762                      mime-preview-over-to-next-method-alist)))
1763         (if f
1764             (funcall (cdr f))
1765           ))
1766     (let ((point
1767            (or (next-single-property-change (point) 'mime-view-entity)
1768                (point-max)))
1769           (bottom (window-end (selected-window))))
1770       (if (and (not h)
1771                (> bottom point))
1772           (progn (goto-char point)
1773                  (recenter next-screen-context-lines))
1774         (condition-case nil
1775             (scroll-up h)
1776           (end-of-buffer
1777            (goto-char (point-max)))))
1778       )))
1779
1780 (defun mime-preview-scroll-down-entity (&optional h)
1781   "Scroll down current entity.
1782 If reached to (point-min), it calls function registered in variable
1783 `mime-preview-over-to-previous-method-alist'."
1784   (interactive)
1785   (if (bobp)
1786       (let ((f (assq (mime-preview-original-major-mode)
1787                      mime-preview-over-to-previous-method-alist)))
1788         (if f
1789             (funcall (cdr f))
1790           ))
1791     (let ((point
1792            (or (previous-single-property-change (point) 'mime-view-entity)
1793                (point-min)))
1794           (top (window-start (selected-window))))
1795       (if (and (not h)
1796                (< top point))
1797           (progn (goto-char point)
1798                  (recenter (* -1 next-screen-context-lines)))
1799         (condition-case nil
1800             (scroll-down h)
1801           (beginning-of-buffer
1802            (goto-char (point-min)))))
1803       )))
1804
1805 (defun mime-preview-next-line-entity (&optional lines)
1806   "Scroll up one line (or prefix LINES lines).
1807 If LINES is negative, scroll down LINES lines."
1808   (interactive "p")
1809   (mime-preview-scroll-up-entity (or lines 1))
1810   )
1811
1812 (defun mime-preview-previous-line-entity (&optional lines)
1813   "Scrroll down one line (or prefix LINES lines).
1814 If LINES is negative, scroll up LINES lines."
1815   (interactive "p")
1816   (mime-preview-scroll-down-entity (or lines 1))
1817   )
1818
1819
1820 ;;; @@ display
1821 ;;;
1822
1823 (defun mime-preview-toggle-display (type &optional display)
1824   (let ((situation (mime-preview-find-boundary-info t))
1825         (sym (intern (concat "*" (symbol-name type))))
1826         entity p-beg p-end)
1827     (setq p-beg (aref situation 0)
1828           p-end (aref situation 1)
1829           entity (aref situation 2)
1830           situation (get-text-property p-beg 'mime-view-situation))
1831     (cond ((eq display 'invisible)
1832            (setq display nil))
1833           (display)
1834           (t
1835            (setq display
1836                  (memq (cdr (or (assq sym situation)
1837                                 (assq type situation)))
1838                        '(nil invisible)))))
1839     (setq situation (put-alist sym (if display
1840                                        'visible
1841                                      'invisible)
1842                                situation))
1843     (save-excursion
1844       (let ((inhibit-read-only t))
1845         (delete-region p-beg p-end)
1846         (mime-display-entity entity situation)))
1847     (let ((ret (assoc situation mime-preview-situation-example-list)))
1848       (if ret
1849           (setcdr ret (1+ (cdr ret)))
1850         (add-to-list 'mime-preview-situation-example-list
1851                      (cons situation 0))))))
1852
1853 (defun mime-preview-toggle-header (&optional force-visible)
1854   (interactive "P")
1855   (mime-preview-toggle-display 'header force-visible))
1856
1857 (defun mime-preview-toggle-content (&optional force-visible)
1858   (interactive "P")
1859   (mime-preview-toggle-display 'body force-visible))
1860
1861 (defun mime-preview-show-header ()
1862   (interactive)
1863   (mime-preview-toggle-display 'header 'visible))
1864
1865 (defun mime-preview-show-content ()
1866   (interactive)
1867   (mime-preview-toggle-display 'body 'visible))
1868
1869 (defun mime-preview-hide-header ()
1870   (interactive)
1871   (mime-preview-toggle-display 'header 'invisible))
1872
1873 (defun mime-preview-hide-content ()
1874   (interactive)
1875   (mime-preview-toggle-display 'body 'invisible))
1876
1877
1878 ;;; @@ quitting
1879 ;;;
1880
1881 (defun mime-preview-quit ()
1882   "Quit from MIME-preview buffer.
1883 It calls function registered in variable
1884 `mime-preview-quitting-method-alist'."
1885   (interactive)
1886   (let ((r (assq (mime-preview-original-major-mode)
1887                  mime-preview-quitting-method-alist)))
1888     (if r
1889         (funcall (cdr r))
1890       )))
1891
1892 (defun mime-preview-kill-buffer ()
1893   (interactive)
1894   (kill-buffer (current-buffer))
1895   )
1896
1897
1898 ;;; @ end
1899 ;;;
1900
1901 (provide 'mime-view)
1902
1903 (eval-when-compile
1904   (setq mime-situation-examples-file nil)
1905   ;; to avoid to read situation-examples-file at compile time.
1906   )
1907
1908 (mime-view-read-situation-examples-file)
1909
1910 ;;; mime-view.el ends here