mime-view.el

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