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