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