mime-view.el

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