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