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