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