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