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