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