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