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