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 (defvar mime-preview-inline-fontify t
 679   "If non-nil, fontify the inline part.")
 680
 681 (ctree-set-calist-strictly
 682  'mime-preview-condition
 683  '((type . nil)
 684    (body . visible)
 685    (body-presentation-method . mime-display-text/plain)))
 686
 687 (ctree-set-calist-strictly
 688  'mime-preview-condition
 689  '((type . text)(subtype . enriched)
 690    (body . visible)
 691    (body-presentation-method . mime-display-text/enriched)))
 692
 693 (ctree-set-calist-strictly
 694  'mime-preview-condition
 695  '((type . text)(subtype . richtext)
 696    (body . visible)
 697    (body-presentation-method . mime-display-text/richtext)))
 698
 699 (autoload 'mime-display-application/x-postpet "postpet")
 700
 701 (ctree-set-calist-strictly
 702  'mime-preview-condition
 703  '((type . application)(subtype . x-postpet)
 704    (body . visible)
 705    (body-presentation-method . mime-display-application/x-postpet)))
 706
 707 (ctree-set-calist-strictly
 708  'mime-preview-condition
 709  '((type . application)(subtype . emacs-lisp)
 710    (body . visible)
 711    (body-presentation-method . mime-display-application/emacs-lisp)))
 712
 713 (ctree-set-calist-strictly
 714  'mime-preview-condition
 715  '((type . text)(subtype . t)
 716    (body . visible)
 717    (body-presentation-method . mime-display-text/plain)))
 718
 719 (ctree-set-calist-strictly
 720  'mime-preview-condition
 721  '((type . multipart)(subtype . alternative)
 722    (body . visible)
 723    (body-presentation-method . mime-display-multipart/alternative)))
 724
 725 (ctree-set-calist-strictly
 726  'mime-preview-condition
 727  '((type . multipart)(subtype . related)
 728    (body . visible)
 729    (body-presentation-method . mime-display-multipart/related)))
 730
 731 (ctree-set-calist-strictly
 732  'mime-preview-condition
 733  '((type . multipart)(subtype . t)
 734    (body . visible)
 735    (body-presentation-method . mime-display-multipart/mixed)))
 736
 737 (ctree-set-calist-strictly
 738  'mime-preview-condition
 739  '((type . message)(subtype . partial)
 740    (body . visible)
 741    (body-presentation-method . mime-display-message/partial-button)))
 742
 743 (ctree-set-calist-strictly
 744  'mime-preview-condition
 745  '((type . message)(subtype . rfc822)
 746    (body . visible)
 747    (body-presentation-method . mime-display-multipart/mixed)
 748    (childrens-situation (header . visible)
 749                         (entity-button . invisible))))
 750
 751 (ctree-set-calist-strictly
 752  'mime-preview-condition
 753  '((type . message)(subtype . news)
 754    (body . visible)
 755    (body-presentation-method . mime-display-multipart/mixed)
 756    (childrens-situation (header . visible)
 757                         (entity-button . invisible))))
 758
 759
 760 ;;; @@@ entity presentation
 761 ;;;
 762
 763 (defun mime-display-text/plain (entity situation)
 764   (save-restriction
 765     (narrow-to-region (point-max)(point-max))
 766     (condition-case nil
 767         (if (and mime-preview-inline-fontify
 768                  (mime-entity-filename entity)) ;should be an attachment.
 769             (mime-display-inline-fontify entity)
 770           (mime-insert-text-content entity))
 771       (error (progn
 772                (message "Can't decode current entity.")
 773                (sit-for 1))))
 774     (run-hooks 'mime-text-decode-hook)
 775     (goto-char (point-max))
 776     (if (not (eq (char-after (1- (point))) ?\n))
 777         (insert "\n"))
 778     (if (and mime-preview-fill-flowed-text
 779              (equal (cdr (assoc "format" situation)) "flowed"))
 780         (fill-flowed))
 781     (mime-add-url-buttons)
 782     (run-hooks 'mime-display-text/plain-hook)))
 783
 784 (defun mime-display-text/richtext (entity situation)
 785   (save-restriction
 786     (narrow-to-region (point-max)(point-max))
 787     (mime-insert-text-content entity)
 788     (run-hooks 'mime-text-decode-hook)
 789     (let ((beg (point-min)))
 790       (remove-text-properties beg (point-max) '(face nil))
 791       (richtext-decode beg (point-max)))))
 792
 793 (defun mime-display-text/enriched (entity situation)
 794   (save-restriction
 795     (narrow-to-region (point-max)(point-max))
 796     (mime-insert-text-content entity)
 797     (run-hooks 'mime-text-decode-hook)
 798     (let ((beg (point-min)))
 799       (remove-text-properties beg (point-max) '(face nil))
 800       (enriched-decode beg (point-max)))))
 801
 802 (defvar mime-view-announcement-for-message/partial
 803   "This is message/partial style split message.")
 804
 805 (defun mime-display-message/partial-button (&optional entity situation)
 806   (save-restriction
 807     (goto-char (point-max))
 808     (if (not (search-backward "\n\n" nil t))
 809         (insert "\n"))
 810     (goto-char (point-max))
 811     (mime-insert-button mime-view-announcement-for-message/partial
 812                         #'mime-preview-play-current-entity)))
 813
 814 (defun mime-display-multipart/mixed (entity situation)
 815   (let ((children (mime-entity-children entity))
 816         (original-major-mode-cell (assq 'major-mode situation))
 817         (default-situation
 818           (cdr (assq 'childrens-situation situation))))
 819     (if original-major-mode-cell
 820         (setq default-situation
 821               (cons original-major-mode-cell default-situation)))
 822     (while children
 823       (mime-display-entity (car children) nil default-situation)
 824       (setq children (cdr children)))))
 825
 826 (defcustom mime-view-type-subtype-score-alist
 827   '(((text . enriched) . 3)
 828     ((text . richtext) . 2)
 829     ((text . plain)    . 1)
 830     (t . 0))
 831   "Alist MEDIA-TYPE vs corresponding score.
 832 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 833   :group 'mime-view
 834   :type '(repeat (cons (choice :tag "Media-Type"
 835                                (cons :tag "Type/Subtype"
 836                                      (symbol :tag "Primary-type")
 837                                      (symbol :tag "Subtype"))
 838                                (symbol :tag "Type")
 839                                (const :tag "Default" t))
 840                        integer)))
 841
 842 (defun mime-display-multipart/alternative (entity situation)
 843   (let* ((children (mime-entity-children entity))
 844          (original-major-mode-cell (assq 'major-mode situation))
 845          (default-situation
 846            (cdr (assq 'childrens-situation situation)))
 847          (i 0)
 848          (p 0)
 849          (max-score 0)
 850          situations)
 851     (if original-major-mode-cell
 852         (setq default-situation
 853               (cons original-major-mode-cell default-situation)))
 854     (setq situations
 855           (mapcar (function
 856                    (lambda (child)
 857                      (let ((situation
 858                             (mime-find-entity-preview-situation
 859                              child default-situation)))
 860                        (if (cdr (assq 'body-presentation-method situation))
 861                            (let ((score
 862                                   (cdr
 863                                    (or (assoc
 864                                         (cons
 865                                          (cdr (assq 'type situation))
 866                                          (cdr (assq 'subtype situation)))
 867                                         mime-view-type-subtype-score-alist)
 868                                        (assq
 869                                         (cdr (assq 'type situation))
 870                                         mime-view-type-subtype-score-alist)
 871                                        (assq
 872                                         t
 873                                         mime-view-type-subtype-score-alist)))))
 874                              (if (> score max-score)
 875                                  (setq p i
 876                                        max-score score))))
 877                        (setq i (1+ i))
 878                        situation)))
 879                   children))
 880     (setq i 0)
 881     (while children
 882       (let ((child (car children))
 883             (situation (car situations)))
 884         (mime-display-entity child (if (= i p)
 885                                        situation
 886                                      (put-alist 'body 'invisible
 887                                                 (copy-alist situation)))))
 888       (setq children (cdr children)
 889             situations (cdr situations)
 890             i (1+ i)))))
 891
 892 (defun mime-display-multipart/related (entity situation)
 893   (let* ((param-start (mime-parse-msg-id
 894                        (std11-lexical-analyze
 895                         (cdr (assoc "start"
 896                                     (mime-content-type-parameters
 897                                      (mime-entity-content-type entity)))))))
 898          (start (or (and param-start (mime-find-entity-from-content-id
 899                                       param-start
 900                                       entity))
 901                     (car (mime-entity-children entity))))
 902          (original-major-mode-cell (assq 'major-mode situation))
 903          (default-situation (cdr (assq 'childrens-situation situation))))
 904     (if original-major-mode-cell
 905         (setq default-situation
 906               (cons original-major-mode-cell default-situation)))
 907     (mime-display-entity start nil default-situation)))
 908
 909 ;;; stolen (and renamed) from mm-view.el.
 910 (defun mime-display-inline-fontify (entity &optional mode)
 911   ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
 912   ;; on for buffers whose name begins with " ".  That's why we use
 913   ;; save-current-buffer/get-buffer-create rather than
 914   ;; with-temp-buffer.
 915   (let ((buffer (get-buffer-create "*fontification*"))
 916         filename)
 917     (save-current-buffer
 918       (set-buffer buffer)
 919       (buffer-disable-undo)
 920       (kill-all-local-variables)
 921       (erase-buffer)
 922       (mime-insert-text-content entity)
 923       (unwind-protect
 924           (progn
 925             (if mode
 926                 (funcall mode)
 927               (if (setq filename (mime-entity-filename entity))
 928                   (set-visited-file-name filename))
 929               (set-auto-mode))
 930             (let ((font-lock-verbose nil))
 931               ;; I find font-lock a bit too verbose.
 932               (font-lock-fontify-buffer))
 933             ;; By default, XEmacs font-lock uses non-duplicable text
 934             ;; properties.  This code forces all the text properties
 935             ;; to be copied along with the text.
 936             (static-when (fboundp 'extent-list)
 937               (map-extents (lambda (ext ignored)
 938                              (set-extent-property ext 'duplicable t)
 939                              nil)
 940                            nil nil nil nil nil 'text-prop)))
 941         (set-visited-file-name nil)))
 942     (insert-buffer-substring buffer)))
 943
 944 (defun mime-display-application/emacs-lisp (entity situation)
 945   (save-restriction
 946     (narrow-to-region (point-max)(point-max))
 947     (mime-display-inline-fontify entity 'emacs-lisp-mode)
 948     (run-hooks 'mime-text-decode-hook 'mime-display-text/plain-hook)))
 949
 950
 951 ;;; @ acting-condition
 952 ;;;
 953
 954 (defvar mime-acting-condition nil
 955   "Condition-tree about how to process entity.")
 956
 957 (defun mime-view-read-mailcap-files (&optional files)
 958   (or files
 959       (setq files mime-view-mailcap-files))
 960   (let (entries file)
 961     (while files
 962       (setq file (car files))
 963       (if (file-readable-p file)
 964           (setq entries (append entries (mime-parse-mailcap-file file))))
 965       (setq files (cdr files)))
 966     (while entries
 967       (let ((entry (car entries))
 968             view print shared)
 969         (while entry
 970           (let* ((field (car entry))
 971                  (field-type (car field)))
 972             (cond ((eq field-type 'view)  (setq view field))
 973                   ((eq field-type 'print) (setq print field))
 974                   ((memq field-type '(compose composetyped edit)))
 975                   (t (setq shared (cons field shared))))
 976             )
 977           (setq entry (cdr entry)))
 978         (setq shared (nreverse shared))
 979         (ctree-set-calist-with-default
 980          'mime-acting-condition
 981          (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 982         (if print
 983             (ctree-set-calist-with-default
 984              'mime-acting-condition
 985              (append shared
 986                      (list '(mode . "print")(cons 'method (cdr view)))))))
 987       (setq entries (cdr entries)))))
 988
 989 (mime-view-read-mailcap-files)
 990
 991 (ctree-set-calist-strictly
 992  'mime-acting-condition
 993  '((type . application)(subtype . octet-stream)
 994    (mode . "play")
 995    (method . mime-detect-content)))
 996
 997 (ctree-set-calist-with-default
 998  'mime-acting-condition
 999  '((mode . "extract")
1000    (method . mime-save-content)))
1001
1002 (ctree-set-calist-strictly
1003  'mime-acting-condition
1004  '((type . text)(subtype . x-rot13-47)(mode . "play")
1005    (method . mime-view-caesar)))
1006 (ctree-set-calist-strictly
1007  'mime-acting-condition
1008  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
1009    (method . mime-view-caesar)))
1010
1011 (ctree-set-calist-strictly
1012  'mime-acting-condition
1013  '((type . message)(subtype . rfc822)(mode . "play")
1014    (method . mime-view-message/rfc822)))
1015 (ctree-set-calist-strictly
1016  'mime-acting-condition
1017  '((type . message)(subtype . partial)(mode . "play")
1018    (method . mime-store-message/partial-piece)))
1019
1020 (ctree-set-calist-strictly
1021  'mime-acting-condition
1022  '((type . message)(subtype . external-body)
1023    ("access-type" . "anon-ftp")
1024    (method . mime-view-message/external-anon-ftp)))
1025
1026 (ctree-set-calist-strictly
1027  'mime-acting-condition
1028  '((type . message)(subtype . external-body)
1029    ("access-type" . "url")
1030    (method . mime-view-message/external-url)))
1031
1032 (ctree-set-calist-strictly
1033  'mime-acting-condition
1034  '((type . application)(subtype . octet-stream)
1035    (method . mime-save-content)))
1036
1037
1038 ;;; @ quitting method
1039 ;;;
1040
1041 (defvar mime-preview-quitting-method-alist
1042   '((mime-show-message-mode
1043      . mime-preview-quitting-method-for-mime-show-message-mode))
1044   "Alist of major-mode vs. quitting-method of mime-view.")
1045
1046 (defvar mime-preview-over-to-previous-method-alist nil
1047   "Alist of major-mode vs. over-to-previous-method of mime-view.")
1048
1049 (defvar mime-preview-over-to-next-method-alist nil
1050   "Alist of major-mode vs. over-to-next-method of mime-view.")
1051
1052
1053 ;;; @ following method
1054 ;;;
1055
1056 (defvar mime-preview-following-method-alist nil
1057   "Alist of major-mode vs. following-method of mime-view.")
1058
1059 (defvar mime-view-following-required-fields-list
1060   '("From"))
1061
1062
1063 ;;; @ buffer setup
1064 ;;;
1065
1066 (defun mime-display-entity (entity &optional situation
1067                                    default-situation preview-buffer)
1068   (or preview-buffer
1069       (setq preview-buffer (current-buffer)))
1070   (let* (e nb ne nhb nbb)
1071     (in-calist-package 'mime-view)
1072     (or situation
1073         (setq situation
1074               (mime-find-entity-preview-situation entity default-situation)))
1075     (let ((button-is-invisible
1076            (eq (cdr (or (assq '*entity-button situation)
1077                         (assq 'entity-button situation)))
1078                'invisible))
1079           (header-is-visible
1080            (eq (cdr (or (assq '*header situation)
1081                         (assq 'header situation)))
1082                'visible))
1083           (body-is-visible
1084            (eq (cdr (or (assq '*body situation)
1085                         (assq 'body situation)))
1086                'visible))
1087           (children (mime-entity-children entity)))
1088       (set-buffer preview-buffer)
1089       (setq nb (point))
1090       (narrow-to-region nb nb)
1091       (or button-is-invisible
1092           ;; (if (mime-view-entity-button-visible-p entity)
1093           (mime-view-insert-entity-button entity)
1094           ;;   )
1095           )
1096       (if header-is-visible
1097           (let ((header-presentation-method
1098                  (or (cdr (assq 'header-presentation-method situation))
1099                      (cdr (assq (cdr (assq 'major-mode situation))
1100                                 mime-header-presentation-method-alist)))))
1101             (setq nhb (point))
1102             (if header-presentation-method
1103                 (funcall header-presentation-method entity situation)
1104               (mime-insert-header entity
1105                                   mime-view-ignored-field-list
1106                                   mime-view-visible-field-list))
1107             (mime-add-url-buttons)
1108             (run-hooks 'mime-display-header-hook)
1109             (put-text-property nhb (point-max) 'mime-view-entity-header entity)
1110             (goto-char (point-max))
1111             (insert "\n")))
1112       (setq nbb (point))
1113       (unless children
1114         (if body-is-visible
1115             (let ((body-presentation-method
1116                    (cdr (assq 'body-presentation-method situation))))
1117               (if (functionp body-presentation-method)
1118                   (funcall body-presentation-method entity situation)
1119                 (mime-display-text/plain entity situation)))
1120           (when button-is-invisible
1121             (goto-char (point-max))
1122             (mime-view-insert-entity-button entity))
1123           (unless header-is-visible
1124             (goto-char (point-max))
1125             (insert "\n"))))
1126       (setq ne (point-max))
1127       (widen)
1128       (put-text-property nb ne 'mime-view-entity entity)
1129       (put-text-property nb ne 'mime-view-situation situation)
1130       (put-text-property nbb ne 'mime-view-entity-body entity)
1131       (goto-char ne)
1132       (if (and children body-is-visible)
1133           (let ((body-presentation-method
1134                  (cdr (assq 'body-presentation-method situation))))
1135             (if (functionp body-presentation-method)
1136                 (funcall body-presentation-method entity situation)
1137               (mime-display-multipart/mixed entity situation)))))))
1138
1139
1140 ;;; @ MIME viewer mode
1141 ;;;
1142
1143 (defconst mime-view-popup-menu-list
1144   '("MIME-View"
1145     ["Move to upper entity" mime-preview-move-to-upper]
1146     ["Move to previous entity" mime-preview-move-to-previous]
1147     ["Move to next entity" mime-preview-move-to-next]
1148     ["Scroll-down" mime-preview-scroll-down-entity]
1149     ["Scroll-up" mime-preview-scroll-up-entity]
1150     ["Play current entity" mime-preview-play-current-entity]
1151     ["Extract current entity" mime-preview-extract-current-entity]
1152     ["Print current entity" mime-preview-print-current-entity])
1153   "Menu for MIME Viewer")
1154
1155 (defun mime-view-popup-menu (event)
1156   "Popup the menu in the MIME Viewer buffer"
1157   (interactive "@e")
1158   (mime-popup-menu-popup mime-view-popup-menu-list event))
1159
1160 ;;; The current local map is taken precendence over `widget-keymap',
1161 ;;; because GNU Emacs' widget implementation doesn't set `local-map' property.
1162 ;;;  So we need to specify derivation.
1163 (defvar widget-keymap)
1164 (defun mime-view-maybe-inherit-widget-keymap ()
1165   (when (boundp 'widget-keymap)
1166     (set-keymap-parent (current-local-map) widget-keymap)))
1167
1168 (add-hook 'mime-view-define-keymap-hook 'mime-view-maybe-inherit-widget-keymap)
1169
1170 (defun mime-view-define-keymap (&optional default)
1171   (let ((mime-view-mode-map (if (keymapp default)
1172                                 (copy-keymap default)
1173                               (make-sparse-keymap))))
1174     (define-key mime-view-mode-map
1175       "u"        (function mime-preview-move-to-upper))
1176     (define-key mime-view-mode-map
1177       "p"        (function mime-preview-move-to-previous))
1178     (define-key mime-view-mode-map
1179       "n"        (function mime-preview-move-to-next))
1180     (define-key mime-view-mode-map
1181       "\e\t"     (function mime-preview-move-to-previous))
1182     (define-key mime-view-mode-map
1183       "\t"       (function mime-preview-move-to-next))
1184     (define-key mime-view-mode-map
1185       " "        (function mime-preview-scroll-up-entity))
1186     (define-key mime-view-mode-map
1187       "\M- "     (function mime-preview-scroll-down-entity))
1188     (define-key mime-view-mode-map
1189       "\177"     (function mime-preview-scroll-down-entity))
1190     (define-key mime-view-mode-map
1191       "\C-m"     (function mime-preview-next-line-entity))
1192     (define-key mime-view-mode-map
1193       "\C-\M-m"  (function mime-preview-previous-line-entity))
1194     (define-key mime-view-mode-map
1195       "v"        (function mime-preview-play-current-entity))
1196     (define-key mime-view-mode-map
1197       "e"        (function mime-preview-extract-current-entity))
1198     (define-key mime-view-mode-map
1199       "\C-c\C-p" (function mime-preview-print-current-entity))
1200
1201     (define-key mime-view-mode-map
1202       "\C-c\C-t\C-f" (function mime-preview-toggle-header))
1203     (define-key mime-view-mode-map
1204       "\C-c\C-th" (function mime-preview-toggle-header))
1205     (define-key mime-view-mode-map
1206       "\C-c\C-t\C-c" (function mime-preview-toggle-content))
1207
1208     (define-key mime-view-mode-map
1209       "\C-c\C-v\C-f" (function mime-preview-show-header))
1210     (define-key mime-view-mode-map
1211       "\C-c\C-vh" (function mime-preview-show-header))
1212     (define-key mime-view-mode-map
1213       "\C-c\C-v\C-c" (function mime-preview-show-content))
1214
1215     (define-key mime-view-mode-map
1216       "\C-c\C-d\C-f" (function mime-preview-hide-header))
1217     (define-key mime-view-mode-map
1218       "\C-c\C-dh" (function mime-preview-hide-header))
1219     (define-key mime-view-mode-map
1220       "\C-c\C-d\C-c" (function mime-preview-hide-content))
1221
1222     (define-key mime-view-mode-map
1223       "a"        (function mime-preview-follow-current-entity))
1224     (define-key mime-view-mode-map
1225       "q"        (function mime-preview-quit))
1226     (define-key mime-view-mode-map
1227       "\C-c\C-x" (function mime-preview-kill-buffer))
1228     ;; (define-key mime-view-mode-map
1229     ;;   "<"        (function beginning-of-buffer))
1230     ;; (define-key mime-view-mode-map
1231     ;;   ">"        (function end-of-buffer))
1232     (define-key mime-view-mode-map
1233       "?"        (function describe-mode))
1234     (define-key mime-view-mode-map
1235       [tab] (function mime-preview-move-to-next))
1236     (define-key mime-view-mode-map
1237       [delete] (function mime-preview-scroll-down-entity))
1238     (define-key mime-view-mode-map
1239       [backspace] (function mime-preview-scroll-down-entity))
1240     (if (functionp default)
1241         (if (featurep 'xemacs)
1242             (set-keymap-default-binding mime-view-mode-map default)
1243           (setq mime-view-mode-map
1244                 (append mime-view-mode-map (list (cons t default))))))
1245     (define-key mime-view-mode-map
1246       [down-mouse-3] (function mime-view-popup-menu))
1247     ;; (run-hooks 'mime-view-define-keymap-hook)
1248     mime-view-mode-map))
1249
1250 (defvar mime-view-mode-default-map (mime-view-define-keymap))
1251
1252
1253 (defsubst mime-maybe-hide-echo-buffer ()
1254   "Clear mime-echo buffer and delete window for it."
1255   (let ((buf (get-buffer mime-echo-buffer-name)))
1256     (if buf
1257         (save-excursion
1258           (set-buffer buf)
1259           (erase-buffer)
1260           (let ((win (get-buffer-window buf)))
1261             (if win
1262                 (delete-window win)))
1263           (bury-buffer buf)))))
1264
1265 (defvar mime-view-redisplay nil)
1266
1267 ;;;###autoload
1268 (defun mime-display-message (message &optional preview-buffer
1269                                      mother default-keymap-or-function
1270                                      original-major-mode keymap)
1271   "View MESSAGE in MIME-View mode.
1272
1273 Optional argument PREVIEW-BUFFER specifies the buffer of the
1274 presentation.  It must be either nil or a name of preview buffer.
1275
1276 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1277
1278 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1279 function.  If it is a keymap, keymap of MIME-View mode will be added
1280 to it.  If it is a function, it will be bound as default binding of
1281 keymap of MIME-View mode.
1282
1283 Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation
1284 buffer of MESSAGE.  If it is nil, current `major-mode' is used.
1285
1286 Optional argument KEYMAP is keymap of MIME-View mode.  If it is
1287 non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored.  If it is nil,
1288 `mime-view-mode-default-map' is used."
1289   (mime-maybe-hide-echo-buffer)
1290   (let ((win-conf (current-window-configuration)))
1291     (or preview-buffer
1292         (setq preview-buffer
1293               (concat "*Preview-" (mime-entity-name message) "*")))
1294     (or original-major-mode
1295         (setq original-major-mode major-mode))
1296     (let ((inhibit-read-only t))
1297       (set-buffer (get-buffer-create preview-buffer))
1298       (widen)
1299       (erase-buffer)
1300       (if mother
1301           (setq mime-mother-buffer mother))
1302       (setq mime-preview-original-window-configuration win-conf)
1303       (setq major-mode 'mime-view-mode)
1304       (setq mode-name "MIME-View")
1305       (mime-display-entity message nil
1306                            `((entity-button . invisible)
1307                              (header . visible)
1308                              (major-mode . ,original-major-mode))
1309                            preview-buffer)
1310       (use-local-map
1311        (or keymap
1312            (if default-keymap-or-function
1313                (mime-view-define-keymap default-keymap-or-function)
1314              mime-view-mode-default-map)))
1315       (let ((point
1316              (next-single-property-change (point-min) 'mime-view-entity)))
1317         (if point
1318             (goto-char point)
1319           (goto-char (point-min))
1320           (search-forward "\n\n" nil t)))
1321       (run-hooks 'mime-view-mode-hook)
1322       (set-buffer-modified-p nil)
1323       (setq buffer-read-only t)
1324       preview-buffer)))
1325
1326 ;;;###autoload
1327 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1328                                    default-keymap-or-function
1329                                    representation-type)
1330   "View RAW-BUFFER in MIME-View mode.
1331 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1332 buffer.
1333 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1334 function.  If it is a keymap, keymap of MIME-View mode will be added
1335 to it.  If it is a function, it will be bound as default binding of
1336 keymap of MIME-View mode.
1337 Optional argument REPRESENTATION-TYPE is representation-type of
1338 message.  It must be nil, `binary' or `cooked'.  If it is nil,
1339 `cooked' is used as default."
1340   (interactive)
1341   (or raw-buffer
1342       (setq raw-buffer (current-buffer)))
1343   (or representation-type
1344       (setq representation-type
1345             (save-excursion
1346               (set-buffer raw-buffer)
1347               (cdr (or (assq major-mode mime-raw-representation-type-alist)
1348                        (assq t mime-raw-representation-type-alist))))))
1349   (if (eq representation-type 'binary)
1350       (setq representation-type 'buffer))
1351   (setq preview-buffer (mime-display-message
1352                         (mime-open-entity representation-type raw-buffer)
1353                         preview-buffer mother default-keymap-or-function))
1354   (or (get-buffer-window preview-buffer)
1355       (let ((r-win (get-buffer-window raw-buffer)))
1356         (if r-win
1357             (set-window-buffer r-win preview-buffer)
1358           (let ((m-win (and mother (get-buffer-window mother))))
1359             (if m-win
1360                 (set-window-buffer m-win preview-buffer)
1361               (switch-to-buffer preview-buffer)))))))
1362
1363 (defun mime-view-mode (&optional mother ctl encoding
1364                                  raw-buffer preview-buffer
1365                                  default-keymap-or-function)
1366   "Major mode for viewing MIME message.
1367
1368 Here is a list of the standard keys for mime-view-mode.
1369
1370 key             feature
1371 ---             -------
1372
1373 u               Move to upper content
1374 p or M-TAB      Move to previous content
1375 n or TAB        Move to next content
1376 SPC             Scroll up or move to next content
1377 M-SPC or DEL    Scroll down or move to previous content
1378 RET             Move to next line
1379 M-RET           Move to previous line
1380 v               Decode current content as `play mode'
1381 e               Decode current content as `extract mode'
1382 C-c C-p         Decode current content as `print mode'
1383 a               Followup to current content.
1384 q               Quit
1385 button-2        Move to point under the mouse cursor
1386                 and decode current content as `play mode'
1387 "
1388   (interactive)
1389   (unless mime-view-redisplay
1390     (save-excursion
1391       (if raw-buffer (set-buffer raw-buffer))
1392       (let ((type
1393              (cdr
1394               (or (assq major-mode mime-raw-representation-type-alist)
1395                   (assq t mime-raw-representation-type-alist)))))
1396         (if (eq type 'binary)
1397             (setq type 'buffer))
1398         (setq mime-message-structure (mime-open-entity type raw-buffer))
1399         (or (mime-entity-content-type mime-message-structure)
1400             (mime-entity-set-content-type mime-message-structure ctl)))
1401       (or (mime-entity-encoding mime-message-structure)
1402           (mime-entity-set-encoding mime-message-structure encoding))))
1403   (mime-display-message mime-message-structure preview-buffer
1404                         mother default-keymap-or-function))
1405
1406
1407 ;;; @@ utility
1408 ;;;
1409
1410 (defun mime-preview-find-boundary-info (&optional get-mother)
1411   (let (entity
1412         p-beg p-end
1413         entity-node-id len)
1414     (while (null (setq entity
1415                        (get-text-property (point) 'mime-view-entity)))
1416       (backward-char))
1417     (setq p-beg (previous-single-property-change (point) 'mime-view-entity))
1418     (setq entity-node-id (mime-entity-node-id entity))
1419     (setq len (length entity-node-id))
1420     (cond ((null p-beg)
1421            (setq p-beg
1422                  (if (eq (next-single-property-change (point-min)
1423                                                       'mime-view-entity)
1424                          (point))
1425                      (point)
1426                    (point-min))))
1427           ((eq (next-single-property-change p-beg 'mime-view-entity)
1428                (point))
1429            (setq p-beg (point))))
1430     (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1431     (cond ((null p-end)
1432            (setq p-end (point-max)))
1433           ((null entity-node-id)
1434            (setq p-end (point-max)))
1435           (get-mother
1436            (save-excursion
1437              (goto-char p-end)
1438              (catch 'tag
1439                (let (e i)
1440                  (while (setq e
1441                               (next-single-property-change
1442                                (point) 'mime-view-entity))
1443                    (goto-char e)
1444                    (let ((rc (mime-entity-node-id
1445                               (get-text-property (1- (point))
1446                                                  'mime-view-entity))))
1447                      (or (and (>= (setq i (- (length rc) len)) 0)
1448                               (equal entity-node-id (nthcdr i rc)))
1449                          (throw 'tag nil)))
1450                    (setq p-end e)))
1451                (setq p-end (point-max))))))
1452     (vector p-beg p-end entity)))
1453
1454
1455 ;;; @@ playing
1456 ;;;
1457
1458 (autoload 'mime-preview-play-current-entity "mime-play"
1459   "Play current entity." t)
1460
1461 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1462   "Extract current entity into file (maybe).
1463 It decodes current entity to call internal or external method as
1464 \"extract\" mode.  The method is selected from variable
1465 `mime-acting-condition'."
1466   (interactive "P")
1467   (mime-preview-play-current-entity ignore-examples "extract"))
1468
1469 (defun mime-preview-print-current-entity (&optional ignore-examples)
1470   "Print current entity (maybe).
1471 It decodes current entity to call internal or external method as
1472 \"print\" mode.  The method is selected from variable
1473 `mime-acting-condition'."
1474   (interactive "P")
1475   (mime-preview-play-current-entity ignore-examples "print"))
1476
1477
1478 ;;; @@ following
1479 ;;;
1480
1481 (defun mime-preview-follow-current-entity ()
1482   "Write follow message to current entity.
1483 It calls following-method selected from variable
1484 `mime-preview-following-method-alist'."
1485   (interactive)
1486   (let ((entity (mime-preview-find-boundary-info t))
1487         p-beg p-end
1488         pb-beg)
1489     (setq p-beg (aref entity 0)
1490           p-end (aref entity 1)
1491           entity (aref entity 2))
1492     (if (get-text-property p-beg 'mime-view-entity-body)
1493         (setq pb-beg p-beg)
1494       (setq pb-beg
1495             (next-single-property-change
1496              p-beg 'mime-view-entity-body nil
1497              (or (next-single-property-change p-beg 'mime-view-entity)
1498                  p-end))))
1499     (let* ((mode (mime-preview-original-major-mode 'recursive))
1500            (entity-node-id (mime-entity-node-id entity))
1501            (new-name
1502             (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1503            new-buf
1504            (the-buf (current-buffer))
1505            fields)
1506       (save-excursion
1507         (set-buffer (setq new-buf (get-buffer-create new-name)))
1508         (erase-buffer)
1509         (insert ?\n)
1510         (insert-buffer-substring the-buf pb-beg p-end)
1511         (goto-char (point-min))
1512         (let ((current-entity
1513                (if (and (eq (mime-entity-media-type entity) 'message)
1514                         (eq (mime-entity-media-subtype entity) 'rfc822))
1515                    (car (mime-entity-children entity))
1516                  entity)))
1517           (while (and current-entity
1518                       (if (and (eq (mime-entity-media-type
1519                                     current-entity) 'message)
1520                                (eq (mime-entity-media-subtype
1521                                     current-entity) 'rfc822))
1522                           nil
1523                         (mime-insert-header current-entity fields)
1524                         t))
1525             (setq fields (std11-collect-field-names)
1526                   current-entity (mime-entity-parent current-entity))))
1527         (let ((rest mime-view-following-required-fields-list)
1528               field-name ret)
1529           (while rest
1530             (setq field-name (car rest))
1531             (or (std11-field-body field-name)
1532                 (progn
1533                   (save-excursion
1534                     (set-buffer the-buf)
1535                     (let ((entity (when mime-mother-buffer
1536                                     (set-buffer mime-mother-buffer)
1537                                     (get-text-property (point)
1538                                                        'mime-view-entity))))
1539                       (while (and entity
1540                                   (null (setq ret (mime-entity-fetch-field
1541                                                    entity field-name))))
1542                         (setq entity (mime-entity-parent entity)))))
1543                   (if ret
1544                       (insert (concat field-name ": " ret "\n")))))
1545             (setq rest (cdr rest)))))
1546       (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1547         (if (functionp f)
1548             (funcall f new-buf)
1549           (message
1550            (format
1551             "Sorry, following method for %s is not implemented yet."
1552             mode)))))))
1553
1554
1555 ;;; @@ moving
1556 ;;;
1557
1558 (defun mime-preview-move-to-upper ()
1559   "Move to upper entity.
1560 If there is no upper entity, call function `mime-preview-quit'."
1561   (interactive)
1562   (let (cinfo)
1563     (while (null (setq cinfo
1564                        (get-text-property (point) 'mime-view-entity)))
1565       (backward-char))
1566     (let ((r (mime-entity-parent cinfo))
1567           point)
1568       (catch 'tag
1569         (while (setq point (previous-single-property-change
1570                             (point) 'mime-view-entity))
1571           (goto-char point)
1572           (when (eq r (get-text-property (point) 'mime-view-entity))
1573             (if (or (eq mime-preview-move-scroll t)
1574                     (and mime-preview-move-scroll
1575                          (>= point
1576                              (save-excursion
1577                                (move-to-window-line -1)
1578                                (forward-line (* -1 next-screen-context-lines))
1579                                (beginning-of-line)
1580                                (point)))))
1581                 (recenter next-screen-context-lines))
1582             (throw 'tag t)))
1583         (mime-preview-quit)))))
1584
1585 (defun mime-preview-move-to-previous ()
1586   "Move to previous entity.
1587 If there is no previous entity, it calls function registered in
1588 variable `mime-preview-over-to-previous-method-alist'."
1589   (interactive)
1590   (while (and (not (bobp))
1591               (null (get-text-property (point) 'mime-view-entity)))
1592     (backward-char))
1593   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1594     (if (and point
1595              (>= point (point-min)))
1596         (if (get-text-property (1- point) 'mime-view-entity)
1597             (progn (goto-char point)
1598                    (if
1599                     (or (eq mime-preview-move-scroll t)
1600                         (and mime-preview-move-scroll
1601                              (<= point
1602                                 (save-excursion
1603                                   (move-to-window-line 0)
1604                                   (forward-line next-screen-context-lines)
1605                                   (end-of-line)
1606                                   (point)))))
1607                         (recenter (* -1 next-screen-context-lines))))
1608           (goto-char (1- point))
1609           (mime-preview-move-to-previous))
1610       (let ((f (assq (mime-preview-original-major-mode)
1611                      mime-preview-over-to-previous-method-alist)))
1612         (if f
1613             (funcall (cdr f)))))))
1614
1615 (defun mime-preview-move-to-next ()
1616   "Move to next entity.
1617 If there is no previous entity, it calls function registered in
1618 variable `mime-preview-over-to-next-method-alist'."
1619   (interactive)
1620   (while (and (not (eobp))
1621               (null (get-text-property (point) 'mime-view-entity)))
1622     (forward-char))
1623   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1624     (if (and point
1625              (<= point (point-max)))
1626         (progn
1627           (goto-char point)
1628           (if (null (get-text-property point 'mime-view-entity))
1629               (mime-preview-move-to-next)
1630             (and
1631              (or (eq mime-preview-move-scroll t)
1632                  (and mime-preview-move-scroll
1633                       (>= point
1634                          (save-excursion
1635                            (move-to-window-line -1)
1636                            (forward-line
1637                             (* -1 next-screen-context-lines))
1638                            (beginning-of-line)
1639                            (point)))))
1640                  (recenter next-screen-context-lines))))
1641       (let ((f (assq (mime-preview-original-major-mode)
1642                      mime-preview-over-to-next-method-alist)))
1643         (if f
1644             (funcall (cdr f)))))))
1645
1646 (defun mime-preview-scroll-up-entity (&optional h)
1647   "Scroll up current entity.
1648 If reached to (point-max), it calls function registered in variable
1649 `mime-preview-over-to-next-method-alist'."
1650   (interactive)
1651   (if (eobp)
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     (let ((point
1657            (or (next-single-property-change (point) 'mime-view-entity)
1658                (point-max)))
1659           (bottom (window-end (selected-window))))
1660       (if (and (not h)
1661                (> bottom point))
1662           (progn (goto-char point)
1663                  (recenter next-screen-context-lines))
1664         (condition-case nil
1665             (scroll-up h)
1666           (end-of-buffer
1667            (goto-char (point-max))))))))
1668
1669 (defun mime-preview-scroll-down-entity (&optional h)
1670   "Scroll down current entity.
1671 If reached to (point-min), it calls function registered in variable
1672 `mime-preview-over-to-previous-method-alist'."
1673   (interactive)
1674   (if (bobp)
1675       (let ((f (assq (mime-preview-original-major-mode)
1676                      mime-preview-over-to-previous-method-alist)))
1677         (if f
1678             (funcall (cdr f))))
1679     (let ((point
1680            (or (previous-single-property-change (point) 'mime-view-entity)
1681                (point-min)))
1682           (top (window-start (selected-window))))
1683       (if (and (not h)
1684                (< top point))
1685           (progn (goto-char point)
1686                  (recenter (* -1 next-screen-context-lines)))
1687         (condition-case nil
1688             (scroll-down h)
1689           (beginning-of-buffer
1690            (goto-char (point-min))))))))
1691
1692 (defun mime-preview-next-line-entity (&optional lines)
1693   "Scroll up one line (or prefix LINES lines).
1694 If LINES is negative, scroll down LINES lines."
1695   (interactive "p")
1696   (mime-preview-scroll-up-entity (or lines 1)))
1697
1698 (defun mime-preview-previous-line-entity (&optional lines)
1699   "Scrroll down one line (or prefix LINES lines).
1700 If LINES is negative, scroll up LINES lines."
1701   (interactive "p")
1702   (mime-preview-scroll-down-entity (or lines 1)))
1703
1704
1705 ;;; @@ display
1706 ;;;
1707
1708 (defun mime-preview-toggle-display (type &optional display)
1709   (let ((situation (mime-preview-find-boundary-info))
1710         (sym (intern (concat "*" (symbol-name type))))
1711         entity p-beg p-end)
1712     (setq p-beg (aref situation 0)
1713           p-end (aref situation 1)
1714           entity (aref situation 2)
1715           situation (get-text-property p-beg 'mime-view-situation))
1716     (cond ((eq display 'invisible)
1717            (setq display nil))
1718           (display)
1719           (t
1720            (setq display
1721                  (memq (cdr (or (assq sym situation)
1722                                 (assq type situation)))
1723                        '(nil invisible)))))
1724     (setq situation (put-alist sym (if display
1725                                        'visible
1726                                      'invisible)
1727                                situation))
1728     (save-excursion
1729       (let ((inhibit-read-only t))
1730         (delete-region p-beg p-end)
1731         (mime-display-entity entity situation)))
1732     (let ((ret (assoc situation mime-preview-situation-example-list)))
1733       (if ret
1734           (setcdr ret (1+ (cdr ret)))
1735         (add-to-list 'mime-preview-situation-example-list
1736                      (cons situation 0))))))
1737
1738 (defun mime-preview-toggle-header (&optional force-visible)
1739   (interactive "P")
1740   (mime-preview-toggle-display 'header force-visible))
1741
1742 (defun mime-preview-toggle-content (&optional force-visible)
1743   (interactive "P")
1744   (mime-preview-toggle-display 'body force-visible))
1745
1746 (defun mime-preview-show-header ()
1747   (interactive)
1748   (mime-preview-toggle-display 'header 'visible))
1749
1750 (defun mime-preview-show-content ()
1751   (interactive)
1752   (mime-preview-toggle-display 'body 'visible))
1753
1754 (defun mime-preview-hide-header ()
1755   (interactive)
1756   (mime-preview-toggle-display 'header 'invisible))
1757
1758 (defun mime-preview-hide-content ()
1759   (interactive)
1760   (mime-preview-toggle-display 'body 'invisible))
1761
1762
1763 ;;; @@ quitting
1764 ;;;
1765
1766 (defun mime-preview-quit ()
1767   "Quit from MIME-preview buffer.
1768 It calls function registered in variable
1769 `mime-preview-quitting-method-alist'."
1770   (interactive)
1771   (let ((r (assq (mime-preview-original-major-mode)
1772                  mime-preview-quitting-method-alist)))
1773     (if r
1774         (funcall (cdr r)))))
1775
1776 (defun mime-preview-kill-buffer ()
1777   (interactive)
1778   (kill-buffer (current-buffer)))
1779
1780
1781 ;;; @ end
1782 ;;;
1783
1784 (provide 'mime-view)
1785
1786 (eval-when-compile
1787   (setq mime-situation-examples-file nil)
1788   ;; to avoid to read situation-examples-file at compile time.
1789   )
1790
1791 (mime-view-read-situation-examples-file)
1792
1793 ;;; mime-view.el ends here