mime-view.el

   1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   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 (Sophisticated Emacs 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 'std11)
  31 (require 'mel)
  32 (require 'eword-decode)
  33 (require 'mime-parse)
  34 (require 'semi-def)
  35 (require 'calist)
  36 (require 'alist)
  37 (require 'mailcap)
  38
  39
  40 ;;; @ version
  41 ;;;
  42
  43 (defconst mime-view-version-string
  44   `,(concat (car mime-module-version) " MIME-View "
  45             (mapconcat #'number-to-string (cddr mime-module-version) ".")
  46             " (" (cadr mime-module-version) ")"))
  47
  48
  49 ;;; @ variables
  50 ;;;
  51
  52 (defgroup mime-view nil
  53   "MIME view mode"
  54   :group 'mime)
  55
  56 (defcustom mime-view-find-every-acting-situation t
  57   "*Find every available acting-situation if non-nil."
  58   :group 'mime-view
  59   :type 'boolean)
  60
  61 (defcustom mime-acting-situation-examples-file "~/.mime-example"
  62   "*File name of example about acting-situation demonstrated by user."
  63   :group 'mime-view
  64   :type 'file)
  65
  66
  67 ;;; @ buffer local variables
  68 ;;;
  69
  70 ;;; @@ in raw-buffer
  71 ;;;
  72
  73 (defvar mime-raw-message-info nil
  74   "Information about structure of message.
  75 Please use reference function `mime-entity-SLOT' to get value of SLOT.
  76
  77 Following is a list of slots of the structure:
  78
  79 buffer                  buffer includes this entity (buffer).
  80 node-id                 node-id (list of integers)
  81 header-start            minimum point of header in raw-buffer
  82 header-end              maximum point of header in raw-buffer
  83 body-start              minimum point of body in raw-buffer
  84 body-end                maximum point of body in raw-buffer
  85 content-type            content-type (content-type)
  86 content-disposition     content-disposition (content-disposition)
  87 encoding                Content-Transfer-Encoding (string or nil)
  88 children                entities included in this entity (list of entity)
  89
  90 If an entity includes other entities in its body, such as multipart or
  91 message/rfc822, `mime-entity' structures of them are included in
  92 `children', so the `mime-entity' structure become a tree.")
  93 (make-variable-buffer-local 'mime-raw-message-info)
  94
  95
  96 (defvar mime-preview-buffer nil
  97   "MIME-preview buffer corresponding with the (raw) buffer.")
  98 (make-variable-buffer-local 'mime-preview-buffer)
  99
 100
 101 (defvar mime-raw-representation-type nil
 102   "Representation-type of mime-raw-buffer.
 103 It must be nil, `binary' or `cooked'.
 104 If it is nil, `mime-raw-representation-type-alist' is used as default
 105 value.
 106 Notice that this variable is usually used as buffer local variable in
 107 raw-buffer.")
 108
 109 (make-variable-buffer-local 'mime-raw-representation-type)
 110
 111 (defvar mime-raw-representation-type-alist
 112   '((mime-show-message-mode     . binary)
 113     (mime-temp-message-mode     . binary)
 114     (t                          . cooked)
 115     )
 116   "Alist of major-mode vs. representation-type of mime-raw-buffer.
 117 Each element looks like (SYMBOL . REPRESENTATION-TYPE).  SYMBOL is
 118 major-mode or t.  t means default.  REPRESENTATION-TYPE must be
 119 `binary' or `cooked'.
 120 This value is overridden by buffer local variable
 121 `mime-raw-representation-type' if it is not nil.")
 122
 123
 124 ;;; @@ in preview-buffer
 125 ;;;
 126
 127 (defvar mime-mother-buffer nil
 128   "Mother buffer corresponding with the (MIME-preview) buffer.
 129 If current MIME-preview buffer is generated by other buffer, such as
 130 message/partial, it is called `mother-buffer'.")
 131 (make-variable-buffer-local 'mime-mother-buffer)
 132
 133 (defvar mime-raw-buffer nil
 134   "Raw buffer corresponding with the (MIME-preview) buffer.")
 135 (make-variable-buffer-local 'mime-raw-buffer)
 136
 137 (defvar mime-preview-original-major-mode nil
 138   "Major-mode of mime-raw-buffer.")
 139 (make-variable-buffer-local 'mime-preview-original-major-mode)
 140
 141 (defvar mime-preview-original-window-configuration nil
 142   "Window-configuration before mime-view-mode is called.")
 143 (make-variable-buffer-local 'mime-preview-original-window-configuration)
 144
 145
 146 ;;; @ entity information
 147 ;;;
 148
 149 (defsubst mime-raw-find-entity-from-node-id (entity-node-id
 150                                              &optional message-info)
 151   "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
 152 If optional argument MESSAGE-INFO is not specified,
 153 `mime-raw-message-info' is used."
 154   (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
 155
 156 (defun mime-raw-find-entity-from-number (entity-number &optional message-info)
 157   "Return entity from ENTITY-NUMBER in mime-raw-buffer.
 158 If optional argument MESSAGE-INFO is not specified,
 159 `mime-raw-message-info' is used."
 160   (or message-info
 161       (setq message-info mime-raw-message-info))
 162   (if (eq entity-number t)
 163       message-info
 164     (let ((sn (car entity-number)))
 165       (if (null sn)
 166           message-info
 167         (let ((rc (nth sn (mime-entity-children message-info))))
 168           (if rc
 169               (mime-raw-find-entity-from-number (cdr entity-number) rc)
 170             ))
 171         ))))
 172
 173 (defun mime-raw-find-entity-from-point (point &optional message-info)
 174   "Return entity from POINT in mime-raw-buffer.
 175 If optional argument MESSAGE-INFO is not specified,
 176 `mime-raw-message-info' is used."
 177   (or message-info
 178       (setq message-info mime-raw-message-info))
 179   (if (and (<= (mime-entity-point-min message-info) point)
 180            (<= point (mime-entity-point-max message-info)))
 181       (let ((children (mime-entity-children message-info)))
 182         (catch 'tag
 183           (while children
 184             (let ((ret
 185                    (mime-raw-find-entity-from-point point (car children))))
 186               (if ret
 187                   (throw 'tag ret)
 188                 ))
 189             (setq children (cdr children)))
 190           message-info))))
 191
 192 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
 193   "Return entity-node-id from POINT in mime-raw-buffer.
 194 If optional argument MESSAGE-INFO is not specified,
 195 `mime-raw-message-info' is used."
 196   (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
 197
 198 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
 199   "Return entity-number from POINT in mime-raw-buffer.
 200 If optional argument MESSAGE-INFO is not specified,
 201 `mime-raw-message-info' is used."
 202   (reverse (mime-raw-point-to-entity-node-id point message-info)))
 203
 204 (defsubst mime-entity-parent (entity &optional message-info)
 205   "Return mother entity of ENTITY.
 206 If optional argument MESSAGE-INFO is not specified,
 207 `mime-raw-message-info' in buffer of ENTITY is used."
 208   (mime-raw-find-entity-from-node-id
 209    (cdr (mime-entity-node-id entity))
 210    (or message-info
 211        (save-excursion
 212          (set-buffer (mime-entity-buffer entity))
 213          mime-raw-message-info))))
 214
 215 (defun mime-raw-flatten-message-info (&optional message-info)
 216   "Return list of entity in mime-raw-buffer.
 217 If optional argument MESSAGE-INFO is not specified,
 218 `mime-raw-message-info' is used."
 219   (or message-info
 220       (setq message-info mime-raw-message-info))
 221   (let ((dest (list message-info))
 222         (rcl (mime-entity-children message-info)))
 223     (while rcl
 224       (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
 225       (setq rcl (cdr rcl)))
 226     dest))
 227
 228
 229 ;;; @ presentation of preview
 230 ;;;
 231
 232 ;;; @@ entity-button
 233 ;;;
 234
 235 ;;; @@@ predicate function
 236 ;;;
 237
 238 (defun mime-view-entity-button-visible-p (entity message-info)
 239   "Return non-nil if header of ENTITY is visible.
 240 Please redefine this function if you want to change default setting."
 241   (let ((media-type (mime-entity-media-type entity))
 242         (media-subtype (mime-entity-media-subtype entity)))
 243     (or (not (eq media-type 'application))
 244         (and (not (eq media-subtype 'x-selection))
 245              (or (not (eq media-subtype 'octet-stream))
 246                  (let ((mother-entity
 247                         (mime-entity-parent entity message-info)))
 248                    (or (not (eq (mime-entity-media-type mother-entity)
 249                                 'multipart))
 250                        (not (eq (mime-entity-media-subtype mother-entity)
 251                                 'encrypted)))
 252                    )
 253                  )))))
 254
 255 ;;; @@@ entity button generator
 256 ;;;
 257
 258 (defun mime-view-insert-entity-button (entity message-info subj)
 259   "Insert entity-button of ENTITY."
 260   (let ((entity-node-id (mime-entity-node-id entity))
 261         (params (mime-entity-parameters entity)))
 262     (mime-insert-button
 263      (let ((access-type (assoc "access-type" params))
 264            (num (or (cdr (assoc "x-part-number" params))
 265                     (if (consp entity-node-id)
 266                         (mapconcat (function
 267                                     (lambda (num)
 268                                       (format "%s" (1+ num))
 269                                       ))
 270                                    (reverse entity-node-id) ".")
 271                       "0"))
 272                 ))
 273        (cond (access-type
 274               (let ((server (assoc "server" params)))
 275                 (setq access-type (cdr access-type))
 276                 (if server
 277                     (format "%s %s ([%s] %s)"
 278                             num subj access-type (cdr server))
 279                 (let ((site (cdr (assoc "site" params)))
 280                       (dir (cdr (assoc "directory" params)))
 281                       )
 282                   (format "%s %s ([%s] %s:%s)"
 283                           num subj access-type site dir)
 284                   )))
 285             )
 286            (t
 287             (let ((media-type (mime-entity-media-type entity))
 288                   (media-subtype (mime-entity-media-subtype entity))
 289                   (charset (cdr (assoc "charset" params)))
 290                   (encoding (mime-entity-encoding entity)))
 291               (concat
 292                num " " subj
 293                (let ((rest
 294                       (format " <%s/%s%s%s>"
 295                               media-type media-subtype
 296                               (if charset
 297                                   (concat "; " charset)
 298                                 "")
 299                               (if encoding
 300                                   (concat " (" encoding ")")
 301                                 ""))))
 302                  (if (>= (+ (current-column)(length rest))(window-width))
 303                      "\n\t")
 304                  rest)))
 305             )))
 306      (function mime-preview-play-current-entity))
 307     ))
 308
 309
 310 ;;; @@ entity-header
 311 ;;;
 312
 313 ;;; @@@ entity header filter
 314 ;;;
 315
 316 (defvar mime-view-content-header-filter-alist nil)
 317
 318 (defun mime-view-default-content-header-filter ()
 319   (mime-view-cut-header)
 320   (eword-decode-header)
 321   )
 322
 323 ;;; @@@ entity field cutter
 324 ;;;
 325
 326 (defvar mime-view-ignored-field-list
 327   '(".*Received" ".*Path" ".*Id" "References"
 328     "Replied" "Errors-To"
 329     "Lines" "Sender" ".*Host" "Xref"
 330     "Content-Type" "Precedence"
 331     "Status" "X-VM-.*")
 332   "All fields that match this list will be hidden in MIME preview buffer.
 333 Each elements are regexp of field-name.")
 334
 335 (defvar mime-view-ignored-field-regexp
 336   (concat "^"
 337           (apply (function regexp-or) mime-view-ignored-field-list)
 338           ":"))
 339
 340 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
 341   "All fields that match this list will be displayed in MIME preview buffer.
 342 Each elements are regexp of field-name.")
 343
 344 (defun mime-view-cut-header ()
 345   (goto-char (point-min))
 346   (while (re-search-forward mime-view-ignored-field-regexp nil t)
 347     (let* ((beg (match-beginning 0))
 348            (end (match-end 0))
 349            (name (buffer-substring beg end))
 350            )
 351       (catch 'visible
 352         (let ((rest mime-view-visible-field-list))
 353           (while rest
 354             (if (string-match (car rest) name)
 355                 (throw 'visible nil)
 356               )
 357             (setq rest (cdr rest))))
 358         (delete-region beg
 359                        (save-excursion
 360                          (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
 361                              (match-beginning 0)
 362                            (point-max))))
 363         ))))
 364
 365
 366 ;;; @@ entity-body
 367 ;;;
 368
 369 ;;; @@@ predicate function
 370 ;;;
 371
 372 (defun mime-calist::field-match-method-as-default-rule (calist
 373                                                         field-type field-value)
 374   (let ((s-field (assq field-type calist)))
 375     (cond ((null s-field)
 376            (cons (cons field-type field-value) calist)
 377            )
 378           (t calist))))
 379
 380 (define-calist-field-match-method
 381   'header #'mime-calist::field-match-method-as-default-rule)
 382
 383 (define-calist-field-match-method
 384   'body #'mime-calist::field-match-method-as-default-rule)
 385
 386
 387 (defvar mime-preview-condition nil
 388   "Condition-tree about how to display entity.")
 389
 390 (ctree-set-calist-strictly
 391  'mime-preview-condition '((type . application)(subtype . octet-stream)
 392                            (encoding . nil)
 393                            (body . visible)))
 394 (ctree-set-calist-strictly
 395  'mime-preview-condition '((type . application)(subtype . octet-stream)
 396                            (encoding . "7bit")
 397                            (body . visible)))
 398 (ctree-set-calist-strictly
 399  'mime-preview-condition '((type . application)(subtype . octet-stream)
 400                            (encoding . "8bit")
 401                            (body . visible)))
 402
 403 (ctree-set-calist-strictly
 404  'mime-preview-condition '((type . application)(subtype . pgp)
 405                            (body . visible)))
 406
 407 (ctree-set-calist-strictly
 408  'mime-preview-condition '((type . application)(subtype . x-latex)
 409                            (body . visible)))
 410
 411 (ctree-set-calist-strictly
 412  'mime-preview-condition '((type . application)(subtype . x-selection)
 413                            (body . visible)))
 414
 415 (ctree-set-calist-strictly
 416  'mime-preview-condition '((type . application)(subtype . x-comment)
 417                            (body . visible)))
 418
 419 (ctree-set-calist-strictly
 420  'mime-preview-condition '((type . message)(subtype . delivery-status)
 421                            (body . visible)))
 422
 423 (ctree-set-calist-strictly
 424  'mime-preview-condition
 425  '((body . visible)
 426    (body-presentation-method . mime-preview-text/plain)))
 427
 428 (ctree-set-calist-strictly
 429  'mime-preview-condition
 430  '((type . nil)
 431    (body . visible)
 432    (body-presentation-method . mime-preview-text/plain)))
 433
 434 (ctree-set-calist-strictly
 435  'mime-preview-condition
 436  '((type . text)(subtype . enriched)
 437    (body . visible)
 438    (body-presentation-method . mime-preview-text/enriched)))
 439
 440 (ctree-set-calist-strictly
 441  'mime-preview-condition
 442  '((type . text)(subtype . richtext)
 443    (body . visible)
 444    (body-presentation-method . mime-preview-text/richtext)))
 445
 446 (ctree-set-calist-strictly
 447  'mime-preview-condition
 448  '((type . text)(subtype . t)
 449    (body . visible)
 450    (body-presentation-method . mime-preview-text/plain)))
 451
 452 (ctree-set-calist-strictly
 453  'mime-preview-condition
 454  '((type . multipart)(subtype . alternative)
 455    (body . visible)
 456    (body-presentation-method . mime-preview-multipart/alternative)))
 457
 458 (ctree-set-calist-strictly
 459  'mime-preview-condition '((type . message)(subtype . partial)
 460                            (body-presentation-method
 461                             . mime-preview-message/partial-button)))
 462
 463 (ctree-set-calist-strictly
 464  'mime-preview-condition '((type . message)(subtype . rfc822)
 465                            (body-presentation-method . nil)
 466                            (childrens-situation (header . visible)
 467                                                 (entity-button . invisible))))
 468
 469 (ctree-set-calist-strictly
 470  'mime-preview-condition '((type . message)(subtype . news)
 471                            (body-presentation-method . nil)
 472                            (childrens-situation (header . visible)
 473                                                 (entity-button . invisible))))
 474
 475
 476 ;;; @@@ entity presentation
 477 ;;;
 478
 479 (autoload 'mime-preview-text/plain "mime-text")
 480 (autoload 'mime-preview-text/enriched "mime-text")
 481 (autoload 'mime-preview-text/richtext "mime-text")
 482
 483 (defvar mime-view-announcement-for-message/partial
 484   (if (and (>= emacs-major-version 19) window-system)
 485       "\
 486 \[[ This is message/partial style split message. ]]
 487 \[[ Please press `v' key in this buffer          ]]
 488 \[[ or click here by mouse button-2.             ]]"
 489     "\
 490 \[[ This is message/partial style split message. ]]
 491 \[[ Please press `v' key in this buffer.         ]]"
 492     ))
 493
 494 (defun mime-preview-message/partial-button (&optional entity situation)
 495   (save-restriction
 496     (goto-char (point-max))
 497     (if (not (search-backward "\n\n" nil t))
 498         (insert "\n")
 499       )
 500     (goto-char (point-max))
 501     (narrow-to-region (point-max)(point-max))
 502     (insert mime-view-announcement-for-message/partial)
 503     (mime-add-button (point-min)(point-max)
 504                      #'mime-preview-play-current-entity)
 505     ))
 506
 507 (defun mime-preview-multipart/mixed (entity situation)
 508   (let ((children (mime-entity-children entity))
 509         (default-situation
 510           (cdr (assq 'childrens-situation situation))))
 511     (while children
 512       (mime-view-display-entity (car children)
 513                                 (save-excursion
 514                                   (set-buffer mime-raw-buffer)
 515                                   mime-raw-message-info)
 516                                 mime-raw-buffer (current-buffer)
 517                                 default-situation)
 518       (setq children (cdr children))
 519       )))
 520
 521 (defcustom mime-view-type-subtype-score-alist
 522   '(((text . enriched) . 3)
 523     ((text . richtext) . 2)
 524     ((text . plain)    . 1)
 525     (t . 0))
 526   "Alist MEDIA-TYPE vs corresponding score.
 527 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t.  t means default."
 528   :group 'mime-view
 529   :type '(repeat (cons (choice :tag "Media-Type"
 530                                (item :tag "Type/Subtype"
 531                                      (cons symbol symbol))
 532                                (item :tag "Type" symbol)
 533                                (item :tag "Default" t))
 534                        integer)))
 535
 536 (defun mime-preview-multipart/alternative (entity situation)
 537   (let* ((children (mime-entity-children entity))
 538          (default-situation
 539            (cdr (assq 'childrens-situation situation)))
 540          (i 0)
 541          (p 0)
 542          (max-score 0)
 543          (situations
 544           (mapcar (function
 545                    (lambda (child)
 546                      (let ((situation
 547                             (or (ctree-match-calist
 548                                  mime-preview-condition
 549                                  (append
 550                                   (or (mime-entity-content-type child)
 551                                       (make-mime-content-type 'text 'plain))
 552                                   (list* (cons 'encoding
 553                                                (mime-entity-encoding child))
 554                                          (cons 'major-mode major-mode)
 555                                          default-situation)))
 556                                 default-situation)))
 557                        (if (cdr (assq 'body-presentation-method situation))
 558                            (let ((score
 559                                   (cdr
 560                                    (or (assoc
 561                                         (cons
 562                                          (cdr (assq 'type situation))
 563                                          (cdr (assq 'subtype situation)))
 564                                         mime-view-type-subtype-score-alist)
 565                                        (assq
 566                                         (cdr (assq 'type situation))
 567                                         mime-view-type-subtype-score-alist)
 568                                        (assq
 569                                         t
 570                                         mime-view-type-subtype-score-alist)
 571                                        ))))
 572                              (if (> score max-score)
 573                                  (setq p i
 574                                        max-score score)
 575                                )))
 576                        (setq i (1+ i))
 577                        situation)
 578                      ))
 579                   children)))
 580     (setq i 0)
 581     (while children
 582       (let ((situation (car situations)))
 583         (mime-view-display-entity (car children)
 584                                   (save-excursion
 585                                     (set-buffer mime-raw-buffer)
 586                                     mime-raw-message-info)
 587                                   mime-raw-buffer (current-buffer)
 588                                   default-situation
 589                                   (if (= i p)
 590                                       situation
 591                                     (del-alist 'body-presentation-method
 592                                                (copy-alist situation))))
 593         )
 594       (setq children (cdr children)
 595             situations (cdr situations)
 596             i (1+ i))
 597       )))
 598
 599
 600 ;;; @ acting-condition
 601 ;;;
 602
 603 (defvar mime-acting-condition nil
 604   "Condition-tree about how to process entity.")
 605
 606 (if (file-readable-p mailcap-file)
 607     (let ((entries (mailcap-parse-file)))
 608       (while entries
 609         (let ((entry (car entries))
 610               view print shared)
 611           (while entry
 612             (let* ((field (car entry))
 613                    (field-type (car field)))
 614               (cond ((eq field-type 'view)  (setq view field))
 615                     ((eq field-type 'print) (setq print field))
 616                     ((memq field-type '(compose composetyped edit)))
 617                     (t (setq shared (cons field shared))))
 618               )
 619             (setq entry (cdr entry))
 620             )
 621           (setq shared (nreverse shared))
 622           (ctree-set-calist-with-default
 623            'mime-acting-condition
 624            (append shared (list '(mode . "play")(cons 'method (cdr view)))))
 625           (if print
 626               (ctree-set-calist-with-default
 627                'mime-acting-condition
 628                (append shared
 629                        (list '(mode . "print")(cons 'method (cdr view))))
 630                ))
 631           )
 632         (setq entries (cdr entries))
 633         )))
 634
 635 ;; (ctree-set-calist-strictly
 636 ;;  'mime-acting-condition
 637 ;;  '((type . t)(subtype . t)(mode . "extract")
 638 ;;    (method . mime-method-to-save)))
 639 (ctree-set-calist-with-default
 640  'mime-acting-condition
 641  '((mode . "extract")
 642    (method . mime-method-to-save)))
 643
 644 ;; (ctree-set-calist-strictly
 645 ;;  'mime-acting-condition
 646 ;;  '((type . text)(subtype . plain)(mode . "play")
 647 ;;    (method "tm-plain" nil 'file "" 'encoding 'mode 'name)
 648 ;;    ))
 649 ;; (ctree-set-calist-strictly
 650 ;;  'mime-acting-condition
 651 ;;  '((type . text)(subtype . plain)(mode . "print")
 652 ;;    (method "tm-plain" nil 'file "" 'encoding 'mode 'name)
 653 ;;    ))
 654 ;; (ctree-set-calist-strictly
 655 ;;  'mime-acting-condition
 656 ;;  '((type . text)(subtype . html)(mode . "play")
 657 ;;    (method "tm-html" nil 'file "" 'encoding 'mode 'name)
 658 ;;    ))
 659 (ctree-set-calist-strictly
 660  'mime-acting-condition
 661  '((type . text)(subtype . x-rot13-47)(mode . "play")
 662    (method . mime-method-to-display-caesar)
 663    ))
 664 (ctree-set-calist-strictly
 665  'mime-acting-condition
 666  '((type . text)(subtype . x-rot13-47-48)(mode . "play")
 667    (method . mime-method-to-display-caesar)
 668    ))
 669
 670 ;; (ctree-set-calist-strictly
 671 ;;  'mime-acting-condition
 672 ;;  '((type . audio)(subtype . basic)(mode . "play")
 673 ;;    (method "tm-au" nil 'file "" 'encoding 'mode 'name)
 674 ;;    ))
 675
 676 ;; (ctree-set-calist-strictly
 677 ;;  'mime-acting-condition
 678 ;;  '((type . image)(mode . "play")
 679 ;;    (method "tm-image" nil 'file "" 'encoding 'mode 'name)
 680 ;;    ))
 681 ;; (ctree-set-calist-strictly
 682 ;;  'mime-acting-condition
 683 ;;  '((type . image)(mode . "print")
 684 ;;    (method "tm-image" nil 'file "" 'encoding 'mode 'name)
 685 ;;    ))
 686
 687 ;; (ctree-set-calist-strictly
 688 ;;  'mime-acting-condition
 689 ;;  '((type . video)(subtype . mpeg)(mode . "play")
 690 ;;    (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name)
 691 ;;    ))
 692
 693 ;; (ctree-set-calist-strictly
 694 ;;  'mime-acting-condition
 695 ;;  '((type . application)(subtype . postscript)(mode . "play")
 696 ;;    (method "tm-ps" nil 'file "" 'encoding 'mode 'name)
 697 ;;    ))
 698 ;; (ctree-set-calist-strictly
 699 ;;  'mime-acting-condition
 700 ;;  '((type . application)(subtype . postscript)(mode . "print")
 701 ;;    (method "tm-ps" nil 'file "" 'encoding 'mode 'name)
 702 ;;    ))
 703
 704 (ctree-set-calist-strictly
 705  'mime-acting-condition
 706  '((type . message)(subtype . rfc822)(mode . "play")
 707    (method . mime-method-to-display-message/rfc822)
 708    ))
 709 (ctree-set-calist-strictly
 710  'mime-acting-condition
 711  '((type . message)(subtype . partial)(mode . "play")
 712    (method . mime-method-to-store-message/partial)
 713    ))
 714
 715 (ctree-set-calist-strictly
 716  'mime-acting-condition
 717  '((type . message)(subtype . external-body)
 718    ("access-type" . "anon-ftp")
 719    (method . mime-method-to-display-message/external-ftp)
 720    ))
 721
 722 (ctree-set-calist-strictly
 723  'mime-acting-condition
 724  '((type . application)(subtype . octet-stream)
 725    (method . mime-method-to-save)
 726    ))
 727
 728
 729 ;;; @ quitting method
 730 ;;;
 731
 732 (defvar mime-preview-quitting-method-alist
 733   '((mime-show-message-mode
 734      . mime-preview-quitting-method-for-mime-show-message-mode))
 735   "Alist of major-mode vs. quitting-method of mime-view.")
 736
 737 (defvar mime-view-over-to-previous-method-alist nil)
 738 (defvar mime-view-over-to-next-method-alist nil)
 739
 740 (defvar mime-view-show-summary-method nil
 741   "Alist of major-mode vs. show-summary-method.")
 742
 743
 744 ;;; @ following method
 745 ;;;
 746
 747 (defvar mime-view-following-method-alist nil
 748   "Alist of major-mode vs. following-method of mime-view.")
 749
 750 (defvar mime-view-following-required-fields-list
 751   '("From"))
 752
 753
 754 ;;; @ X-Face
 755 ;;;
 756
 757 ;; hack from Gnus 5.0.4.
 758
 759 (defvar mime-view-x-face-to-pbm-command
 760   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
 761
 762 (defvar mime-view-x-face-command
 763   (concat mime-view-x-face-to-pbm-command
 764           " | xv -quit -")
 765   "String to be executed to display an X-Face field.
 766 The command will be executed in a sub-shell asynchronously.
 767 The compressed face will be piped to this command.")
 768
 769 (defun mime-view-x-face-function ()
 770   "Function to display X-Face field. You can redefine to customize."
 771   ;; 1995/10/12 (c.f. tm-eng:130)
 772   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
 773   (save-restriction
 774     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
 775     ;; end
 776     (goto-char (point-min))
 777     (if (re-search-forward "^X-Face:[ \t]*" nil t)
 778         (let ((beg (match-end 0))
 779               (end (std11-field-end))
 780               )
 781           (call-process-region beg end "sh" nil 0 nil
 782                                "-c" mime-view-x-face-command)
 783           ))))
 784
 785
 786 ;;; @ miscellaneous
 787 ;;;
 788
 789 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
 790
 791
 792 ;;; @ buffer setup
 793 ;;;
 794
 795 (defvar mime-view-redisplay nil)
 796
 797 (defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf)
 798   (if ibuf
 799       (progn
 800         (get-buffer ibuf)
 801         (set-buffer ibuf)
 802         ))
 803   (or mime-view-redisplay
 804       (setq mime-raw-message-info (mime-parse-message ctl encoding))
 805       )
 806   (let ((message-info mime-raw-message-info)
 807         (the-buf (current-buffer))
 808         (mode major-mode))
 809     (or obuf
 810         (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
 811     (set-buffer (get-buffer-create obuf))
 812     (let ((inhibit-read-only t))
 813       ;;(setq buffer-read-only nil)
 814       (widen)
 815       (erase-buffer)
 816       (setq mime-raw-buffer the-buf)
 817       (setq mime-preview-original-major-mode mode)
 818       (setq major-mode 'mime-view-mode)
 819       (setq mode-name "MIME-View")
 820       (mime-view-display-entity message-info message-info
 821                                 the-buf obuf
 822                                 '((entity-button . invisible)
 823                                   (header . visible)
 824                                   ))
 825       (set-buffer-modified-p nil)
 826       )
 827     (setq buffer-read-only t)
 828     (set-buffer the-buf)
 829     )
 830   (setq mime-preview-buffer obuf)
 831   )
 832
 833 (defun mime-view-display-entity (entity message-info ibuf obuf
 834                                         default-situation
 835                                         &optional situation)
 836   (let* ((start (mime-entity-point-min entity))
 837          (end (mime-entity-point-max entity))
 838          (content-type (mime-entity-content-type entity))
 839          (encoding (mime-entity-encoding entity))
 840          end-of-header e nb ne subj)
 841     (set-buffer ibuf)
 842     (goto-char start)
 843     (setq end-of-header (if (re-search-forward "^$" nil t)
 844                             (1+ (match-end 0))
 845                           end))
 846     (if (> end-of-header end)
 847         (setq end-of-header end)
 848       )
 849     (save-restriction
 850       (narrow-to-region start end)
 851       (setq subj (eword-decode-string (mime-raw-get-subject entity)))
 852       )
 853     (or situation
 854         (setq situation
 855               (or (ctree-match-calist mime-preview-condition
 856                                       (append
 857                                        (or content-type
 858                                            (make-mime-content-type
 859                                             'text 'plain))
 860                                        (list* (cons 'encoding   encoding)
 861                                               (cons 'major-mode major-mode)
 862                                               default-situation)))
 863                   default-situation)))
 864     (let ((button-is-invisible
 865            (eq (cdr (assq 'entity-button situation)) 'invisible))
 866           (header-is-visible
 867            (eq (cdr (assq 'header situation)) 'visible))
 868           (body-presentation-method
 869            (cdr (assq 'body-presentation-method situation)))
 870           (children (mime-entity-children entity)))
 871       (set-buffer obuf)
 872       (setq nb (point))
 873       (narrow-to-region nb nb)
 874       (or button-is-invisible
 875           (if (mime-view-entity-button-visible-p entity message-info)
 876               (mime-view-insert-entity-button entity message-info subj)
 877             ))
 878       (if header-is-visible
 879           (save-restriction
 880             (narrow-to-region (point)(point))
 881             (insert-buffer-substring mime-raw-buffer start end-of-header)
 882             (let ((f (cdr (assq mime-preview-original-major-mode
 883                                 mime-view-content-header-filter-alist))))
 884               (if (functionp f)
 885                   (funcall f)
 886                 (mime-view-default-content-header-filter)
 887                 ))
 888             (run-hooks 'mime-view-content-header-filter-hook)
 889             ))
 890       (cond ((eq body-presentation-method 'with-filter)
 891              (let ((body-filter (cdr (assq 'body-filter situation))))
 892                (save-restriction
 893                  (narrow-to-region (point-max)(point-max))
 894                  (insert-buffer-substring mime-raw-buffer end-of-header end)
 895                  (funcall body-filter situation)
 896                  )))
 897             (children)
 898             ((functionp body-presentation-method)
 899              (funcall body-presentation-method entity situation)
 900              )
 901             (t
 902              (when button-is-invisible
 903                (goto-char (point-max))
 904                (mime-view-insert-entity-button entity message-info subj)
 905                )
 906              (or header-is-visible
 907                  (progn
 908                    (goto-char (point-max))
 909                    (insert "\n")
 910                    ))
 911              ))
 912       (setq ne (point-max))
 913       (widen)
 914       (put-text-property nb ne 'mime-view-raw-buffer ibuf)
 915       (put-text-property nb ne 'mime-view-entity entity)
 916       (goto-char ne)
 917       (if children
 918           (if (functionp body-presentation-method)
 919               (funcall body-presentation-method entity situation)
 920             (mime-preview-multipart/mixed entity situation)
 921             ))
 922       )))
 923
 924 (defun mime-raw-get-uu-filename ()
 925   (save-excursion
 926     (if (re-search-forward "^begin [0-9]+ " nil t)
 927         (if (looking-at ".+$")
 928             (buffer-substring (match-beginning 0)(match-end 0))
 929           ))))
 930
 931 (defun mime-raw-get-subject (entity)
 932   (or (std11-find-field-body '("Content-Description" "Subject"))
 933       (let ((ret (mime-entity-content-disposition entity)))
 934         (and ret
 935              (setq ret (mime-content-disposition-filename ret))
 936              (std11-strip-quoted-string ret)
 937              ))
 938       (let ((ret (mime-entity-content-type entity)))
 939         (and ret
 940              (setq ret
 941                    (cdr
 942                     (let ((param (mime-content-type-parameters ret)))
 943                       (or (assoc "name" param)
 944                           (assoc "x-name" param))
 945                       )))
 946              (std11-strip-quoted-string ret)
 947              ))
 948       (if (member (mime-entity-encoding entity)
 949                   mime-view-uuencode-encoding-name-list)
 950           (mime-raw-get-uu-filename))
 951       ""))
 952
 953
 954 ;;; @ MIME viewer mode
 955 ;;;
 956
 957 (defconst mime-view-menu-title "MIME-View")
 958 (defconst mime-view-menu-list
 959   '((up          "Move to upper entity"    mime-preview-move-to-upper)
 960     (previous    "Move to previous entity" mime-preview-move-to-previous)
 961     (next        "Move to next entity"     mime-preview-move-to-next)
 962     (scroll-down "Scroll-down"             mime-preview-scroll-down-entity)
 963     (scroll-up   "Scroll-up"               mime-preview-scroll-up-entity)
 964     (play        "Play current entity"     mime-preview-play-current-entity)
 965     (extract     "Extract current entity"  mime-preview-extract-current-entity)
 966     (print       "Print current entity"    mime-preview-print-current-entity)
 967     (x-face      "Show X Face"             mime-preview-display-x-face)
 968     )
 969   "Menu for MIME Viewer")
 970
 971 (cond (running-xemacs
 972        (defvar mime-view-xemacs-popup-menu
 973          (cons mime-view-menu-title
 974                (mapcar (function
 975                         (lambda (item)
 976                           (vector (nth 1 item)(nth 2 item) t)
 977                           ))
 978                        mime-view-menu-list)))
 979        (defun mime-view-xemacs-popup-menu (event)
 980          "Popup the menu in the MIME Viewer buffer"
 981          (interactive "e")
 982          (select-window (event-window event))
 983          (set-buffer (event-buffer event))
 984          (popup-menu 'mime-view-xemacs-popup-menu))
 985        (defvar mouse-button-2 'button2)
 986        )
 987       (t
 988        (defvar mouse-button-2 [mouse-2])
 989        ))
 990
 991 (defun mime-view-define-keymap (&optional default)
 992   (let ((mime-view-mode-map (if (keymapp default)
 993                                 (copy-keymap default)
 994                               (make-sparse-keymap)
 995                               )))
 996     (define-key mime-view-mode-map
 997       "u"        (function mime-preview-move-to-upper))
 998     (define-key mime-view-mode-map
 999       "p"        (function mime-preview-move-to-previous))
1000     (define-key mime-view-mode-map
1001       "n"        (function mime-preview-move-to-next))
1002     (define-key mime-view-mode-map
1003       "\e\t"     (function mime-preview-move-to-previous))
1004     (define-key mime-view-mode-map
1005       "\t"       (function mime-preview-move-to-next))
1006     (define-key mime-view-mode-map
1007       " "        (function mime-preview-scroll-up-entity))
1008     (define-key mime-view-mode-map
1009       "\M- "     (function mime-preview-scroll-down-entity))
1010     (define-key mime-view-mode-map
1011       "\177"     (function mime-preview-scroll-down-entity))
1012     (define-key mime-view-mode-map
1013       "\C-m"     (function mime-preview-next-line-entity))
1014     (define-key mime-view-mode-map
1015       "\C-\M-m"  (function mime-preview-previous-line-entity))
1016     (define-key mime-view-mode-map
1017       "v"        (function mime-preview-play-current-entity))
1018     (define-key mime-view-mode-map
1019       "e"        (function mime-preview-extract-current-entity))
1020     (define-key mime-view-mode-map
1021       "\C-c\C-p" (function mime-preview-print-current-entity))
1022     (define-key mime-view-mode-map
1023       "a"        (function mime-preview-follow-current-entity))
1024     (define-key mime-view-mode-map
1025       "q"        (function mime-preview-quit))
1026     (define-key mime-view-mode-map
1027       "h"        (function mime-preview-show-summary))
1028     (define-key mime-view-mode-map
1029       "\C-c\C-x" (function mime-preview-kill-buffer))
1030     ;; (define-key mime-view-mode-map
1031     ;;   "<"        (function beginning-of-buffer))
1032     ;; (define-key mime-view-mode-map
1033     ;;   ">"        (function end-of-buffer))
1034     (define-key mime-view-mode-map
1035       "?"        (function describe-mode))
1036     (define-key mime-view-mode-map
1037       [tab] (function mime-preview-move-to-next))
1038     (define-key mime-view-mode-map
1039       [delete] (function mime-preview-scroll-down-entity))
1040     (define-key mime-view-mode-map
1041       [backspace] (function mime-preview-scroll-down-entity))
1042     (if (functionp default)
1043         (cond (running-xemacs
1044                (set-keymap-default-binding mime-view-mode-map default)
1045                )
1046               (t
1047                (setq mime-view-mode-map
1048                      (append mime-view-mode-map (list (cons t default))))
1049                )))
1050     (if mouse-button-2
1051         (define-key mime-view-mode-map
1052           mouse-button-2 (function mime-button-dispatcher))
1053       )
1054     (cond (running-xemacs
1055            (define-key mime-view-mode-map
1056              mouse-button-3 (function mime-view-xemacs-popup-menu))
1057            )
1058           ((>= emacs-major-version 19)
1059            (define-key mime-view-mode-map [menu-bar mime-view]
1060              (cons mime-view-menu-title
1061                    (make-sparse-keymap mime-view-menu-title)))
1062            (mapcar (function
1063                     (lambda (item)
1064                       (define-key mime-view-mode-map
1065                         (vector 'menu-bar 'mime-view (car item))
1066                         (cons (nth 1 item)(nth 2 item))
1067                         )
1068                       ))
1069                    (reverse mime-view-menu-list)
1070                    )
1071            ))
1072     (use-local-map mime-view-mode-map)
1073     (run-hooks 'mime-view-define-keymap-hook)
1074     ))
1075
1076 (defsubst mime-maybe-hide-echo-buffer ()
1077   "Clear mime-echo buffer and delete window for it."
1078   (let ((buf (get-buffer mime-echo-buffer-name)))
1079     (if buf
1080         (save-excursion
1081           (set-buffer buf)
1082           (erase-buffer)
1083           (let ((win (get-buffer-window buf)))
1084             (if win
1085                 (delete-window win)
1086               ))
1087           (bury-buffer buf)
1088           ))))
1089
1090 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
1091                                  default-keymap-or-function)
1092   "Major mode for viewing MIME message.
1093
1094 Here is a list of the standard keys for mime-view-mode.
1095
1096 key             feature
1097 ---             -------
1098
1099 u               Move to upper content
1100 p or M-TAB      Move to previous content
1101 n or TAB        Move to next content
1102 SPC             Scroll up or move to next content
1103 M-SPC or DEL    Scroll down or move to previous content
1104 RET             Move to next line
1105 M-RET           Move to previous line
1106 v               Decode current content as `play mode'
1107 e               Decode current content as `extract mode'
1108 C-c C-p         Decode current content as `print mode'
1109 a               Followup to current content.
1110 x               Display X-Face
1111 q               Quit
1112 button-2        Move to point under the mouse cursor
1113                 and decode current content as `play mode'
1114 "
1115   (interactive)
1116   (mime-maybe-hide-echo-buffer)
1117   (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
1118         (win-conf (current-window-configuration))
1119         )
1120     (prog1
1121         (switch-to-buffer ret)
1122       (setq mime-preview-original-window-configuration win-conf)
1123       (if mother
1124           (progn
1125             (setq mime-mother-buffer mother)
1126             ))
1127       (mime-view-define-keymap default-keymap-or-function)
1128       (let ((point
1129              (next-single-property-change (point-min) 'mime-view-entity)))
1130         (if point
1131             (goto-char point)
1132           (goto-char (point-min))
1133           (search-forward "\n\n" nil t)
1134           ))
1135       (run-hooks 'mime-view-mode-hook)
1136       )))
1137
1138
1139 ;;; @@ playing
1140 ;;;
1141
1142 (autoload 'mime-preview-play-current-entity "mime-play"
1143   "Play current entity." t)
1144
1145 (defun mime-preview-extract-current-entity ()
1146   "Extract current entity into file (maybe).
1147 It decodes current entity to call internal or external method as
1148 \"extract\" mode.  The method is selected from variable
1149 `mime-acting-condition'."
1150   (interactive)
1151   (mime-preview-play-current-entity "extract")
1152   )
1153
1154 (defun mime-preview-print-current-entity ()
1155   "Print current entity (maybe).
1156 It decodes current entity to call internal or external method as
1157 \"print\" mode.  The method is selected from variable
1158 `mime-acting-condition'."
1159   (interactive)
1160   (mime-preview-play-current-entity "print")
1161   )
1162
1163
1164 ;;; @@ following
1165 ;;;
1166
1167 (defun mime-preview-original-major-mode ()
1168   "Return major-mode of original buffer.
1169 If a current buffer has mime-mother-buffer, return original major-mode
1170 of the mother-buffer."
1171   (if mime-mother-buffer
1172       (save-excursion
1173         (set-buffer mime-mother-buffer)
1174         (mime-preview-original-major-mode)
1175         )
1176     mime-preview-original-major-mode))
1177
1178 (defun mime-preview-follow-current-entity ()
1179   "Write follow message to current entity.
1180 It calls following-method selected from variable
1181 `mime-view-following-method-alist'."
1182   (interactive)
1183   (let (entity)
1184     (while (null (setq entity
1185                        (get-text-property (point) 'mime-view-entity)))
1186       (backward-char)
1187       )
1188     (let* ((p-beg
1189             (previous-single-property-change (point) 'mime-view-entity))
1190            p-end
1191            (entity-node-id (mime-entity-node-id entity))
1192            (len (length entity-node-id))
1193            )
1194       (cond ((null p-beg)
1195              (setq p-beg
1196                    (if (eq (next-single-property-change (point-min)
1197                                                         'mime-view-entity)
1198                            (point))
1199                        (point)
1200                      (point-min)))
1201              )
1202             ((eq (next-single-property-change p-beg 'mime-view-entity)
1203                  (point))
1204              (setq p-beg (point))
1205              ))
1206       (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1207       (cond ((null p-end)
1208              (setq p-end (point-max))
1209              )
1210             ((null entity-node-id)
1211              (setq p-end (point-max))
1212              )
1213             (t
1214              (save-excursion
1215                (goto-char p-end)
1216                (catch 'tag
1217                  (let (e)
1218                    (while (setq e
1219                                 (next-single-property-change
1220                                  (point) 'mime-view-entity))
1221                      (goto-char e)
1222                      (let ((rc (mime-entity-node-id
1223                                 (get-text-property (point)
1224                                                    'mime-view-entity))))
1225                        (or (equal entity-node-id
1226                                   (nthcdr (- (length rc) len) rc))
1227                            (throw 'tag nil)
1228                            ))
1229                      (setq p-end e)
1230                      ))
1231                  (setq p-end (point-max))
1232                  ))
1233              ))
1234       (let* ((mode (mime-preview-original-major-mode))
1235              (new-name
1236               (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1237              new-buf
1238              (the-buf (current-buffer))
1239              (a-buf mime-raw-buffer)
1240              fields)
1241         (save-excursion
1242           (set-buffer (setq new-buf (get-buffer-create new-name)))
1243           (erase-buffer)
1244           (insert-buffer-substring the-buf p-beg p-end)
1245           (goto-char (point-min))
1246           (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1247             (while (progn
1248                      (setq
1249                       str
1250                       (save-excursion
1251                         (set-buffer a-buf)
1252                         (setq
1253                          ci
1254                          (mime-raw-find-entity-from-node-id entity-node-id))
1255                         (save-restriction
1256                           (narrow-to-region
1257                            (mime-entity-point-min ci)
1258                            (mime-entity-point-max ci)
1259                            )
1260                           (std11-header-string-except
1261                            (concat "^"
1262                                    (apply (function regexp-or) fields)
1263                                    ":") ""))))
1264                      (if (and
1265                           (eq (mime-entity-media-type ci) 'message)
1266                           (eq (mime-entity-media-subtype ci) 'rfc822))
1267                          nil
1268                        (if str
1269                            (insert str)
1270                          )
1271                        entity-node-id))
1272               (setq fields (std11-collect-field-names)
1273                     entity-node-id (cdr entity-node-id))
1274               )
1275             )
1276           (let ((rest mime-view-following-required-fields-list))
1277             (while rest
1278               (let ((field-name (car rest)))
1279                 (or (std11-field-body field-name)
1280                     (insert
1281                      (format
1282                       (concat field-name
1283                               ": "
1284                               (save-excursion
1285                                 (set-buffer the-buf)
1286                                 (set-buffer mime-mother-buffer)
1287                                 (set-buffer mime-raw-buffer)
1288                                 (std11-field-body field-name)
1289                                 )
1290                               "\n")))
1291                     ))
1292               (setq rest (cdr rest))
1293               ))
1294           (eword-decode-header)
1295           )
1296         (let ((f (cdr (assq mode mime-view-following-method-alist))))
1297           (if (functionp f)
1298               (funcall f new-buf)
1299             (message
1300              (format
1301               "Sorry, following method for %s is not implemented yet."
1302               mode))
1303             ))
1304         ))))
1305
1306
1307 ;;; @@ X-Face
1308 ;;;
1309
1310 (defun mime-preview-display-x-face ()
1311   (interactive)
1312   (save-window-excursion
1313     (set-buffer mime-raw-buffer)
1314     (mime-view-x-face-function)
1315     ))
1316
1317
1318 ;;; @@ moving
1319 ;;;
1320
1321 (defun mime-preview-move-to-upper ()
1322   "Move to upper entity.
1323 If there is no upper entity, call function `mime-preview-quit'."
1324   (interactive)
1325   (let (cinfo)
1326     (while (null (setq cinfo
1327                        (get-text-property (point) 'mime-view-entity)))
1328       (backward-char)
1329       )
1330     (let ((r (mime-raw-find-entity-from-node-id
1331               (cdr (mime-entity-node-id cinfo))
1332               (get-text-property 1 'mime-view-entity)))
1333           point)
1334       (catch 'tag
1335         (while (setq point (previous-single-property-change
1336                             (point) 'mime-view-entity))
1337           (goto-char point)
1338           (if (eq r (get-text-property (point) 'mime-view-entity))
1339               (throw 'tag t)
1340             )
1341           )
1342         (mime-preview-quit)
1343         ))))
1344
1345 (defun mime-preview-move-to-previous ()
1346   "Move to previous entity.
1347 If there is no previous entity, it calls function registered in
1348 variable `mime-view-over-to-previous-method-alist'."
1349   (interactive)
1350   (while (null (get-text-property (point) 'mime-view-entity))
1351     (backward-char)
1352     )
1353   (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1354     (if point
1355         (if (get-text-property (1- point) 'mime-view-entity)
1356             (goto-char point)
1357           (goto-char (1- point))
1358           (mime-preview-move-to-previous)
1359           )
1360       (let ((f (assq mime-preview-original-major-mode
1361                      mime-view-over-to-previous-method-alist)))
1362         (if f
1363             (funcall (cdr f))
1364           ))
1365       )))
1366
1367 (defun mime-preview-move-to-next ()
1368   "Move to next entity.
1369 If there is no previous entity, it calls function registered in
1370 variable `mime-view-over-to-next-method-alist'."
1371   (interactive)
1372   (while (null (get-text-property (point) 'mime-view-entity))
1373     (forward-char)
1374     )
1375   (let ((point (next-single-property-change (point) 'mime-view-entity)))
1376     (if point
1377         (progn
1378           (goto-char point)
1379           (if (null (get-text-property point 'mime-view-entity))
1380               (mime-preview-move-to-next)
1381             ))
1382       (let ((f (assq mime-preview-original-major-mode
1383                      mime-view-over-to-next-method-alist)))
1384         (if f
1385             (funcall (cdr f))
1386           ))
1387       )))
1388
1389 (defun mime-preview-scroll-up-entity (&optional h)
1390   "Scroll up current entity.
1391 If reached to (point-max), it calls function registered in variable
1392 `mime-view-over-to-next-method-alist'."
1393   (interactive)
1394   (or h
1395       (setq h (1- (window-height)))
1396       )
1397   (if (= (point) (point-max))
1398       (let ((f (assq mime-preview-original-major-mode
1399                      mime-view-over-to-next-method-alist)))
1400         (if f
1401             (funcall (cdr f))
1402           ))
1403     (let ((point
1404            (or (next-single-property-change (point) 'mime-view-entity)
1405                (point-max))))
1406       (forward-line h)
1407       (if (> (point) point)
1408           (goto-char point)
1409         )
1410       )))
1411
1412 (defun mime-preview-scroll-down-entity (&optional h)
1413   "Scroll down current entity.
1414 If reached to (point-min), it calls function registered in variable
1415 `mime-view-over-to-previous-method-alist'."
1416   (interactive)
1417   (or h
1418       (setq h (1- (window-height)))
1419       )
1420   (if (= (point) (point-min))
1421       (let ((f (assq mime-preview-original-major-mode
1422                      mime-view-over-to-previous-method-alist)))
1423         (if f
1424             (funcall (cdr f))
1425           ))
1426     (let (point)
1427       (save-excursion
1428         (catch 'tag
1429           (while (not (bobp))
1430             (if (setq point
1431                       (previous-single-property-change (point)
1432                                                        'mime-view-entity))
1433                 (throw 'tag t)
1434               )
1435             (backward-char)
1436             )
1437           (setq point (point-min))
1438           ))
1439       (forward-line (- h))
1440       (if (< (point) point)
1441           (goto-char point)
1442         ))))
1443
1444 (defun mime-preview-next-line-entity ()
1445   (interactive)
1446   (mime-preview-scroll-up-entity 1)
1447   )
1448
1449 (defun mime-preview-previous-line-entity ()
1450   (interactive)
1451   (mime-preview-scroll-down-entity 1)
1452   )
1453
1454
1455 ;;; @@ quitting
1456 ;;;
1457
1458 (defun mime-preview-quit ()
1459   "Quit from MIME-preview buffer.
1460 It calls function registered in variable
1461 `mime-preview-quitting-method-alist'."
1462   (interactive)
1463   (let ((r (assq mime-preview-original-major-mode
1464                  mime-preview-quitting-method-alist)))
1465     (if r
1466         (funcall (cdr r))
1467       )))
1468
1469 (defun mime-preview-show-summary ()
1470   "Show summary.
1471 It calls function registered in variable
1472 `mime-view-show-summary-method'."
1473   (interactive)
1474   (let ((r (assq mime-preview-original-major-mode
1475                  mime-view-show-summary-method)))
1476     (if r
1477         (funcall (cdr r))
1478       )))
1479
1480 (defun mime-preview-kill-buffer ()
1481   (interactive)
1482   (kill-buffer (current-buffer))
1483   )
1484
1485
1486 ;;; @ end
1487 ;;;
1488
1489 (provide 'mime-view)
1490
1491 (run-hooks 'mime-view-load-hook)
1492
1493 ;;; mime-view.el ends here