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