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