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