mime-view.el

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