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