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