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