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