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