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