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