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