1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
7 ;; Renamed: 1994/08/31 from tm-body.el
8 ;; Renamed: 1997/02/19 from tm-view.el
9 ;; Keywords: MIME, multimedia, mail, news
11 ;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces).
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.
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.
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.
32 (require 'eword-decode)
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) ")"))
52 (defgroup mime-view nil
56 (defcustom mime-view-find-every-acting-situation t
57 "*Find every available acting-situation if non-nil."
61 (defcustom mime-acting-situation-examples-file "~/.mime-example"
62 "*File name of example about acting-situation demonstrated by user."
67 ;;; @ in raw-buffer (representation space)
70 (defvar mime-raw-message-info nil
71 "Information about structure of message.
72 Please use reference function `mime-entity-SLOT' to get value of SLOT.
74 Following is a list of slots of the structure:
76 buffer buffer includes this entity (buffer).
77 node-id node-id (list of integers)
78 header-start minimum point of header in raw-buffer
79 header-end maximum point of header in raw-buffer
80 body-start minimum point of body in raw-buffer
81 body-end maximum point of body in raw-buffer
82 content-type content-type (content-type)
83 content-disposition content-disposition (content-disposition)
84 encoding Content-Transfer-Encoding (string or nil)
85 children entities included in this entity (list of entity)
87 If an entity includes other entities in its body, such as multipart or
88 message/rfc822, `mime-entity' structures of them are included in
89 `children', so the `mime-entity' structure become a tree.")
90 (make-variable-buffer-local 'mime-raw-message-info)
93 (defvar mime-preview-buffer nil
94 "MIME-preview buffer corresponding with the (raw) buffer.")
95 (make-variable-buffer-local 'mime-preview-buffer)
98 (defvar mime-raw-representation-type nil
99 "Representation-type of mime-raw-buffer.
100 It must be nil, `binary' or `cooked'.
101 If it is nil, `mime-raw-representation-type-alist' is used as default
103 Notice that this variable is usually used as buffer local variable in
106 (make-variable-buffer-local 'mime-raw-representation-type)
108 (defvar mime-raw-representation-type-alist
109 '((mime-show-message-mode . binary)
110 (mime-temp-message-mode . binary)
113 "Alist of major-mode vs. representation-type of mime-raw-buffer.
114 Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
115 major-mode or t. t means default. REPRESENTATION-TYPE must be
116 `binary' or `cooked'.
117 This value is overridden by buffer local variable
118 `mime-raw-representation-type' if it is not nil.")
121 (defsubst mime-raw-find-entity-from-node-id (entity-node-id
122 &optional message-info)
123 "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
124 If optional argument MESSAGE-INFO is not specified,
125 `mime-raw-message-info' is used."
126 (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
128 (defun mime-raw-find-entity-from-number (entity-number &optional message-info)
129 "Return entity from ENTITY-NUMBER in mime-raw-buffer.
130 If optional argument MESSAGE-INFO is not specified,
131 `mime-raw-message-info' is used."
133 (setq message-info mime-raw-message-info))
134 (if (eq entity-number t)
136 (let ((sn (car entity-number)))
139 (let ((rc (nth sn (mime-entity-children message-info))))
141 (mime-raw-find-entity-from-number (cdr entity-number) rc)
145 (defun mime-raw-find-entity-from-point (point &optional message-info)
146 "Return entity from POINT in mime-raw-buffer.
147 If optional argument MESSAGE-INFO is not specified,
148 `mime-raw-message-info' is used."
150 (setq message-info mime-raw-message-info))
151 (if (and (<= (mime-entity-point-min message-info) point)
152 (<= point (mime-entity-point-max message-info)))
153 (let ((children (mime-entity-children message-info)))
157 (mime-raw-find-entity-from-point point (car children))))
161 (setq children (cdr children)))
165 ;;; @ in preview-buffer (presentation space)
168 (defvar mime-mother-buffer nil
169 "Mother buffer corresponding with the (MIME-preview) buffer.
170 If current MIME-preview buffer is generated by other buffer, such as
171 message/partial, it is called `mother-buffer'.")
172 (make-variable-buffer-local 'mime-mother-buffer)
174 (defvar mime-raw-buffer nil
175 "Raw buffer corresponding with the (MIME-preview) buffer.")
176 (make-variable-buffer-local 'mime-raw-buffer)
178 (defvar mime-preview-original-window-configuration nil
179 "Window-configuration before mime-view-mode is called.")
180 (make-variable-buffer-local 'mime-preview-original-window-configuration)
182 (defun mime-preview-original-major-mode (&optional recursive)
183 "Return major-mode of original buffer.
184 If optional argument RECURSIVE is non-nil and current buffer has
185 mime-mother-buffer, it returns original major-mode of the
187 (if (and recursive mime-mother-buffer)
189 (set-buffer mime-mother-buffer)
190 (mime-preview-original-major-mode recursive)
195 (get-text-property (point-min) 'mime-view-entity)))
199 ;;; @ entity information
202 (defsubst mime-entity-parent (entity &optional message-info)
203 "Return mother entity of ENTITY.
204 If optional argument MESSAGE-INFO is not specified,
205 `mime-raw-message-info' in buffer of ENTITY is used."
206 (mime-raw-find-entity-from-node-id
207 (cdr (mime-entity-node-id entity))
210 (set-buffer (mime-entity-buffer entity))
211 mime-raw-message-info))))
213 (defun mime-entity-situation (entity)
214 "Return situation of ENTITY."
215 (append (or (mime-entity-content-type entity)
216 (make-mime-content-type 'text 'plain))
217 (let ((d (mime-entity-content-disposition entity)))
218 (cons (cons 'disposition-type
219 (mime-content-disposition-type d))
222 (let ((name (car param)))
223 (cons (cond ((string= name "filename")
225 ((string= name "creation-date")
227 ((string= name "modification-date")
229 ((string= name "read-date")
231 ((string= name "size")
233 (t (cons 'disposition (car param))))
235 (mime-content-disposition-parameters d))
237 (list (cons 'encoding (mime-entity-encoding entity))
240 (set-buffer (mime-entity-buffer entity))
245 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
247 (defun mime-raw-get-uu-filename ()
249 (if (re-search-forward "^begin [0-9]+ " nil t)
250 (if (looking-at ".+$")
251 (buffer-substring (match-beginning 0)(match-end 0))
254 (defun mime-raw-get-subject (entity)
255 (or (std11-find-field-body '("Content-Description" "Subject"))
256 (let ((ret (mime-entity-content-disposition entity)))
258 (setq ret (mime-content-disposition-filename ret))
259 (std11-strip-quoted-string ret)
261 (let ((ret (mime-entity-content-type entity)))
265 (let ((param (mime-content-type-parameters ret)))
266 (or (assoc "name" param)
267 (assoc "x-name" param))
269 (std11-strip-quoted-string ret)
271 (if (member (mime-entity-encoding entity)
272 mime-view-uuencode-encoding-name-list)
273 (mime-raw-get-uu-filename))
277 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
278 "Return entity-node-id from POINT in mime-raw-buffer.
279 If optional argument MESSAGE-INFO is not specified,
280 `mime-raw-message-info' is used."
281 (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
283 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
284 "Return entity-number from POINT in mime-raw-buffer.
285 If optional argument MESSAGE-INFO is not specified,
286 `mime-raw-message-info' is used."
287 (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
289 (defun mime-raw-flatten-message-info (&optional message-info)
290 "Return list of entity in mime-raw-buffer.
291 If optional argument MESSAGE-INFO is not specified,
292 `mime-raw-message-info' is used."
294 (setq message-info mime-raw-message-info))
295 (let ((dest (list message-info))
296 (rcl (mime-entity-children message-info)))
298 (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
299 (setq rcl (cdr rcl)))
303 ;;; @ presentation of preview
309 ;;; @@@ predicate function
312 (defun mime-view-entity-button-visible-p (entity)
313 "Return non-nil if header of ENTITY is visible.
314 Please redefine this function if you want to change default setting."
315 (let ((media-type (mime-entity-media-type entity))
316 (media-subtype (mime-entity-media-subtype entity)))
317 (or (not (eq media-type 'application))
318 (and (not (eq media-subtype 'x-selection))
319 (or (not (eq media-subtype 'octet-stream))
320 (let ((mother-entity (mime-entity-parent entity)))
321 (or (not (eq (mime-entity-media-type mother-entity)
323 (not (eq (mime-entity-media-subtype mother-entity)
328 ;;; @@@ entity button generator
331 (defun mime-view-insert-entity-button (entity subject)
332 "Insert entity-button of ENTITY."
333 (let ((entity-node-id (mime-entity-node-id entity))
334 (params (mime-entity-parameters entity)))
336 (let ((access-type (assoc "access-type" params))
337 (num (or (cdr (assoc "x-part-number" params))
338 (if (consp entity-node-id)
341 (format "%s" (1+ num))
343 (reverse entity-node-id) ".")
347 (let ((server (assoc "server" params)))
348 (setq access-type (cdr access-type))
350 (format "%s %s ([%s] %s)"
351 num subject access-type (cdr server))
352 (let ((site (cdr (assoc "site" params)))
353 (dir (cdr (assoc "directory" params)))
355 (format "%s %s ([%s] %s:%s)"
356 num subject access-type site dir)
360 (let ((media-type (mime-entity-media-type entity))
361 (media-subtype (mime-entity-media-subtype entity))
362 (charset (cdr (assoc "charset" params)))
363 (encoding (mime-entity-encoding entity)))
367 (format " <%s/%s%s%s>"
368 media-type media-subtype
370 (concat "; " charset)
373 (concat " (" encoding ")")
375 (if (>= (+ (current-column)(length rest))(window-width))
379 (function mime-preview-play-current-entity))
386 ;;; @@@ entity header filter
389 (defvar mime-view-content-header-filter-alist nil)
391 (defun mime-view-default-content-header-filter ()
392 (mime-view-cut-header)
393 (eword-decode-header)
396 ;;; @@@ entity field cutter
399 (defvar mime-view-ignored-field-list
400 '(".*Received" ".*Path" ".*Id" "References"
401 "Replied" "Errors-To"
402 "Lines" "Sender" ".*Host" "Xref"
403 "Content-Type" "Precedence"
405 "All fields that match this list will be hidden in MIME preview buffer.
406 Each elements are regexp of field-name.")
408 (defvar mime-view-ignored-field-regexp
410 (apply (function regexp-or) mime-view-ignored-field-list)
413 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
414 "All fields that match this list will be displayed in MIME preview buffer.
415 Each elements are regexp of field-name.")
417 (defun mime-view-cut-header ()
418 (goto-char (point-min))
419 (while (re-search-forward mime-view-ignored-field-regexp nil t)
420 (let* ((beg (match-beginning 0))
422 (name (buffer-substring beg end))
425 (let ((rest mime-view-visible-field-list))
427 (if (string-match (car rest) name)
430 (setq rest (cdr rest))))
433 (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
442 ;;; @@@ predicate function
445 (defun mime-calist::field-match-method-as-default-rule (calist
446 field-type field-value)
447 (let ((s-field (assq field-type calist)))
448 (cond ((null s-field)
449 (cons (cons field-type field-value) calist)
453 (define-calist-field-match-method
454 'header #'mime-calist::field-match-method-as-default-rule)
456 (define-calist-field-match-method
457 'body #'mime-calist::field-match-method-as-default-rule)
460 (defvar mime-preview-condition nil
461 "Condition-tree about how to display entity.")
463 (ctree-set-calist-strictly
464 'mime-preview-condition '((type . application)(subtype . octet-stream)
467 (ctree-set-calist-strictly
468 'mime-preview-condition '((type . application)(subtype . octet-stream)
471 (ctree-set-calist-strictly
472 'mime-preview-condition '((type . application)(subtype . octet-stream)
476 (ctree-set-calist-strictly
477 'mime-preview-condition '((type . application)(subtype . pgp)
480 (ctree-set-calist-strictly
481 'mime-preview-condition '((type . application)(subtype . x-latex)
484 (ctree-set-calist-strictly
485 'mime-preview-condition '((type . application)(subtype . x-selection)
488 (ctree-set-calist-strictly
489 'mime-preview-condition '((type . application)(subtype . x-comment)
492 (ctree-set-calist-strictly
493 'mime-preview-condition '((type . message)(subtype . delivery-status)
496 (ctree-set-calist-strictly
497 'mime-preview-condition
499 (body-presentation-method . mime-preview-text/plain)))
501 (ctree-set-calist-strictly
502 'mime-preview-condition
505 (body-presentation-method . mime-preview-text/plain)))
507 (ctree-set-calist-strictly
508 'mime-preview-condition
509 '((type . text)(subtype . enriched)
511 (body-presentation-method . mime-preview-text/enriched)))
513 (ctree-set-calist-strictly
514 'mime-preview-condition
515 '((type . text)(subtype . richtext)
517 (body-presentation-method . mime-preview-text/richtext)))
519 (ctree-set-calist-strictly
520 'mime-preview-condition
521 '((type . text)(subtype . t)
523 (body-presentation-method . mime-preview-text/plain)))
525 (ctree-set-calist-strictly
526 'mime-preview-condition
527 '((type . multipart)(subtype . alternative)
529 (body-presentation-method . mime-preview-multipart/alternative)))
531 (ctree-set-calist-strictly
532 'mime-preview-condition '((type . message)(subtype . partial)
533 (body-presentation-method
534 . mime-preview-message/partial-button)))
536 (ctree-set-calist-strictly
537 'mime-preview-condition '((type . message)(subtype . rfc822)
538 (body-presentation-method . nil)
539 (childrens-situation (header . visible)
540 (entity-button . invisible))))
542 (ctree-set-calist-strictly
543 'mime-preview-condition '((type . message)(subtype . news)
544 (body-presentation-method . nil)
545 (childrens-situation (header . visible)
546 (entity-button . invisible))))
549 ;;; @@@ entity presentation
552 (autoload 'mime-preview-text/plain "mime-text")
553 (autoload 'mime-preview-text/enriched "mime-text")
554 (autoload 'mime-preview-text/richtext "mime-text")
556 (defvar mime-view-announcement-for-message/partial
557 (if (and (>= emacs-major-version 19) window-system)
559 \[[ This is message/partial style split message. ]]
560 \[[ Please press `v' key in this buffer ]]
561 \[[ or click here by mouse button-2. ]]"
563 \[[ This is message/partial style split message. ]]
564 \[[ Please press `v' key in this buffer. ]]"
567 (defun mime-preview-message/partial-button (&optional entity situation)
569 (goto-char (point-max))
570 (if (not (search-backward "\n\n" nil t))
573 (goto-char (point-max))
574 (narrow-to-region (point-max)(point-max))
575 (insert mime-view-announcement-for-message/partial)
576 (mime-add-button (point-min)(point-max)
577 #'mime-preview-play-current-entity)
580 (defun mime-preview-multipart/mixed (entity situation)
581 (let ((children (mime-entity-children entity))
583 (cdr (assq 'childrens-situation situation))))
585 (mime-view-display-entity (car children)
587 (set-buffer (mime-entity-buffer entity))
588 mime-raw-message-info)
591 (setq children (cdr children))
594 (defcustom mime-view-type-subtype-score-alist
595 '(((text . enriched) . 3)
596 ((text . richtext) . 2)
599 "Alist MEDIA-TYPE vs corresponding score.
600 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
602 :type '(repeat (cons (choice :tag "Media-Type"
603 (item :tag "Type/Subtype"
604 (cons symbol symbol))
605 (item :tag "Type" symbol)
606 (item :tag "Default" t))
609 (defun mime-preview-multipart/alternative (entity situation)
610 (let* ((children (mime-entity-children entity))
612 (cdr (assq 'childrens-situation situation)))
620 (or (ctree-match-calist
621 mime-preview-condition
622 (append (mime-entity-situation child)
625 (if (cdr (assq 'body-presentation-method situation))
630 (cdr (assq 'type situation))
631 (cdr (assq 'subtype situation)))
632 mime-view-type-subtype-score-alist)
634 (cdr (assq 'type situation))
635 mime-view-type-subtype-score-alist)
638 mime-view-type-subtype-score-alist)
640 (if (> score max-score)
650 (let ((child (car children))
651 (situation (car situations)))
652 (mime-view-display-entity child
654 (set-buffer (mime-entity-buffer child))
655 mime-raw-message-info)
660 (del-alist 'body-presentation-method
661 (copy-alist situation))))
663 (setq children (cdr children)
664 situations (cdr situations)
669 ;;; @ acting-condition
672 (defvar mime-acting-condition nil
673 "Condition-tree about how to process entity.")
675 (if (file-readable-p mailcap-file)
676 (let ((entries (mailcap-parse-file)))
678 (let ((entry (car entries))
681 (let* ((field (car entry))
682 (field-type (car field)))
683 (cond ((eq field-type 'view) (setq view field))
684 ((eq field-type 'print) (setq print field))
685 ((memq field-type '(compose composetyped edit)))
686 (t (setq shared (cons field shared))))
688 (setq entry (cdr entry))
690 (setq shared (nreverse shared))
691 (ctree-set-calist-with-default
692 'mime-acting-condition
693 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
695 (ctree-set-calist-with-default
696 'mime-acting-condition
698 (list '(mode . "print")(cons 'method (cdr view))))
701 (setq entries (cdr entries))
704 (ctree-set-calist-strictly
705 'mime-acting-condition
706 '((type . application)(subtype . octet-stream)
708 (method . mime-method-to-detect)
711 (ctree-set-calist-with-default
712 'mime-acting-condition
714 (method . mime-method-to-save)))
716 (ctree-set-calist-strictly
717 'mime-acting-condition
718 '((type . text)(subtype . x-rot13-47)(mode . "play")
719 (method . mime-method-to-display-caesar)
721 (ctree-set-calist-strictly
722 'mime-acting-condition
723 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
724 (method . mime-method-to-display-caesar)
727 (ctree-set-calist-strictly
728 'mime-acting-condition
729 '((type . message)(subtype . rfc822)(mode . "play")
730 (method . mime-method-to-display-message/rfc822)
732 (ctree-set-calist-strictly
733 'mime-acting-condition
734 '((type . message)(subtype . partial)(mode . "play")
735 (method . mime-method-to-store-message/partial)
738 (ctree-set-calist-strictly
739 'mime-acting-condition
740 '((type . message)(subtype . external-body)
741 ("access-type" . "anon-ftp")
742 (method . mime-method-to-display-message/external-ftp)
745 (ctree-set-calist-strictly
746 'mime-acting-condition
747 '((type . application)(subtype . octet-stream)
748 (method . mime-method-to-save)
752 ;;; @ quitting method
755 (defvar mime-preview-quitting-method-alist
756 '((mime-show-message-mode
757 . mime-preview-quitting-method-for-mime-show-message-mode))
758 "Alist of major-mode vs. quitting-method of mime-view.")
760 (defvar mime-preview-over-to-previous-method-alist nil
761 "Alist of major-mode vs. over-to-previous-method of mime-view.")
763 (defvar mime-preview-over-to-next-method-alist nil
764 "Alist of major-mode vs. over-to-next-method of mime-view.")
767 ;;; @ following method
770 (defvar mime-view-following-method-alist nil
771 "Alist of major-mode vs. following-method of mime-view.")
773 (defvar mime-view-following-required-fields-list
780 ;; hack from Gnus 5.0.4.
782 (defvar mime-view-x-face-to-pbm-command
783 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
785 (defvar mime-view-x-face-command
786 (concat mime-view-x-face-to-pbm-command
788 "String to be executed to display an X-Face field.
789 The command will be executed in a sub-shell asynchronously.
790 The compressed face will be piped to this command.")
792 (defun mime-view-x-face-function ()
793 "Function to display X-Face field. You can redefine to customize."
794 ;; 1995/10/12 (c.f. tm-eng:130)
795 ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
797 (narrow-to-region (point-min) (re-search-forward "^$" nil t))
799 (goto-char (point-min))
800 (if (re-search-forward "^X-Face:[ \t]*" nil t)
801 (let ((beg (match-end 0))
802 (end (std11-field-end))
804 (call-process-region beg end "sh" nil 0 nil
805 "-c" mime-view-x-face-command)
812 (defun mime-view-display-entity (entity message-info obuf
815 (let* ((raw-buffer (mime-entity-buffer entity))
816 (start (mime-entity-point-min entity))
817 (end (mime-entity-point-max entity))
818 original-major-mode end-of-header e nb ne subj)
819 (set-buffer raw-buffer)
820 (setq original-major-mode major-mode)
822 (setq end-of-header (if (re-search-forward "^$" nil t)
825 (if (> end-of-header end)
826 (setq end-of-header end)
829 (narrow-to-region start end)
830 (setq subj (eword-decode-string (mime-raw-get-subject entity)))
834 (or (ctree-match-calist mime-preview-condition
835 (append (mime-entity-situation entity)
838 (let ((button-is-invisible
839 (eq (cdr (assq 'entity-button situation)) 'invisible))
841 (eq (cdr (assq 'header situation)) 'visible))
842 (body-presentation-method
843 (cdr (assq 'body-presentation-method situation)))
844 (children (mime-entity-children entity)))
847 (narrow-to-region nb nb)
848 (or button-is-invisible
849 (if (mime-view-entity-button-visible-p entity)
850 (mime-view-insert-entity-button entity subj)
852 (if header-is-visible
854 (narrow-to-region (point)(point))
855 (insert-buffer-substring raw-buffer start end-of-header)
856 (let ((f (cdr (assq original-major-mode
857 mime-view-content-header-filter-alist))))
860 (mime-view-default-content-header-filter)
862 (run-hooks 'mime-view-content-header-filter-hook)
864 (cond ((eq body-presentation-method 'with-filter)
865 (let ((body-filter (cdr (assq 'body-filter situation))))
867 (narrow-to-region (point-max)(point-max))
868 (insert-buffer-substring raw-buffer end-of-header end)
869 (funcall body-filter situation)
872 ((functionp body-presentation-method)
873 (funcall body-presentation-method entity situation)
876 (when button-is-invisible
877 (goto-char (point-max))
878 (mime-view-insert-entity-button entity subj)
880 (or header-is-visible
882 (goto-char (point-max))
886 (setq ne (point-max))
888 (put-text-property nb ne 'mime-view-entity entity)
891 (if (functionp body-presentation-method)
892 (funcall body-presentation-method entity situation)
893 (mime-preview-multipart/mixed entity situation)
898 ;;; @ MIME viewer mode
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)
913 "Menu for MIME Viewer")
915 (cond (running-xemacs
916 (defvar mime-view-xemacs-popup-menu
917 (cons mime-view-menu-title
920 (vector (nth 1 item)(nth 2 item) t)
922 mime-view-menu-list)))
923 (defun mime-view-xemacs-popup-menu (event)
924 "Popup the menu in the MIME Viewer buffer"
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)
932 (defvar mouse-button-2 [mouse-2])
935 (defun mime-view-define-keymap (&optional default)
936 (let ((mime-view-mode-map (if (keymapp default)
937 (copy-keymap default)
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 "\C-c\C-x" (function mime-preview-kill-buffer))
972 ;; (define-key mime-view-mode-map
973 ;; "<" (function beginning-of-buffer))
974 ;; (define-key mime-view-mode-map
975 ;; ">" (function end-of-buffer))
976 (define-key mime-view-mode-map
977 "?" (function describe-mode))
978 (define-key mime-view-mode-map
979 [tab] (function mime-preview-move-to-next))
980 (define-key mime-view-mode-map
981 [delete] (function mime-preview-scroll-down-entity))
982 (define-key mime-view-mode-map
983 [backspace] (function mime-preview-scroll-down-entity))
984 (if (functionp default)
985 (cond (running-xemacs
986 (set-keymap-default-binding mime-view-mode-map default)
989 (setq mime-view-mode-map
990 (append mime-view-mode-map (list (cons t default))))
993 (define-key mime-view-mode-map
994 mouse-button-2 (function mime-button-dispatcher))
996 (cond (running-xemacs
997 (define-key mime-view-mode-map
998 mouse-button-3 (function mime-view-xemacs-popup-menu))
1000 ((>= emacs-major-version 19)
1001 (define-key mime-view-mode-map [menu-bar mime-view]
1002 (cons mime-view-menu-title
1003 (make-sparse-keymap mime-view-menu-title)))
1006 (define-key mime-view-mode-map
1007 (vector 'menu-bar 'mime-view (car item))
1008 (cons (nth 1 item)(nth 2 item))
1011 (reverse mime-view-menu-list)
1014 (use-local-map mime-view-mode-map)
1015 (run-hooks 'mime-view-define-keymap-hook)
1018 (defsubst mime-maybe-hide-echo-buffer ()
1019 "Clear mime-echo buffer and delete window for it."
1020 (let ((buf (get-buffer mime-echo-buffer-name)))
1025 (let ((win (get-buffer-window buf)))
1032 (defvar mime-view-redisplay nil)
1034 (defun mime-view-display-message (message &optional preview-buffer
1035 mother default-keymap-or-function)
1036 (mime-maybe-hide-echo-buffer)
1037 (let ((win-conf (current-window-configuration))
1038 (raw-buffer (mime-entity-buffer message)))
1040 (setq preview-buffer
1041 (concat "*Preview-" (buffer-name raw-buffer) "*")))
1042 (set-buffer raw-buffer)
1043 (setq mime-raw-message-info (mime-parse-message))
1044 (setq mime-preview-buffer preview-buffer)
1045 (let ((inhibit-read-only t))
1046 (switch-to-buffer preview-buffer)
1049 (setq mime-raw-buffer raw-buffer)
1051 (setq mime-mother-buffer mother)
1053 (setq mime-preview-original-window-configuration win-conf)
1054 (setq major-mode 'mime-view-mode)
1055 (setq mode-name "MIME-View")
1056 (mime-view-display-entity message message
1058 '((entity-button . invisible)
1061 (mime-view-define-keymap default-keymap-or-function)
1063 (next-single-property-change (point-min) 'mime-view-entity)))
1066 (goto-char (point-min))
1067 (search-forward "\n\n" nil t)
1069 (run-hooks 'mime-view-mode-hook)
1071 (set-buffer-modified-p nil)
1072 (setq buffer-read-only t)
1075 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1076 default-keymap-or-function)
1078 (mime-view-display-message
1080 (if raw-buffer (set-buffer raw-buffer))
1081 (mime-parse-message)
1083 preview-buffer mother default-keymap-or-function))
1085 (defun mime-view-mode (&optional mother ctl encoding
1086 raw-buffer preview-buffer
1087 default-keymap-or-function)
1088 "Major mode for viewing MIME message.
1090 Here is a list of the standard keys for mime-view-mode.
1095 u Move to upper content
1096 p or M-TAB Move to previous content
1097 n or TAB Move to next content
1098 SPC Scroll up or move to next content
1099 M-SPC or DEL Scroll down or move to previous content
1100 RET Move to next line
1101 M-RET Move to previous line
1102 v Decode current content as `play mode'
1103 e Decode current content as `extract mode'
1104 C-c C-p Decode current content as `print mode'
1105 a Followup to current content.
1107 button-2 Move to point under the mouse cursor
1108 and decode current content as `play mode'
1111 (mime-view-display-message
1113 (if raw-buffer (set-buffer raw-buffer))
1114 (or mime-view-redisplay
1115 (mime-parse-message ctl encoding))
1117 preview-buffer mother default-keymap-or-function))
1123 (autoload 'mime-preview-play-current-entity "mime-play"
1124 "Play current entity." t)
1126 (defun mime-preview-extract-current-entity ()
1127 "Extract current entity into file (maybe).
1128 It decodes current entity to call internal or external method as
1129 \"extract\" mode. The method is selected from variable
1130 `mime-acting-condition'."
1132 (mime-preview-play-current-entity "extract")
1135 (defun mime-preview-print-current-entity ()
1136 "Print current entity (maybe).
1137 It decodes current entity to call internal or external method as
1138 \"print\" mode. The method is selected from variable
1139 `mime-acting-condition'."
1141 (mime-preview-play-current-entity "print")
1148 (defun mime-preview-follow-current-entity ()
1149 "Write follow message to current entity.
1150 It calls following-method selected from variable
1151 `mime-view-following-method-alist'."
1154 (while (null (setq entity
1155 (get-text-property (point) 'mime-view-entity)))
1159 (previous-single-property-change (point) 'mime-view-entity))
1161 (entity-node-id (mime-entity-node-id entity))
1162 (len (length entity-node-id))
1166 (if (eq (next-single-property-change (point-min)
1172 ((eq (next-single-property-change p-beg 'mime-view-entity)
1174 (setq p-beg (point))
1176 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1178 (setq p-end (point-max))
1180 ((null entity-node-id)
1181 (setq p-end (point-max))
1189 (next-single-property-change
1190 (point) 'mime-view-entity))
1192 (let ((rc (mime-entity-node-id
1193 (get-text-property (point)
1194 'mime-view-entity))))
1195 (or (equal entity-node-id
1196 (nthcdr (- (length rc) len) rc))
1201 (setq p-end (point-max))
1204 (let* ((mode (mime-preview-original-major-mode 'recursive))
1206 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1208 (the-buf (current-buffer))
1209 (a-buf mime-raw-buffer)
1212 (set-buffer (setq new-buf (get-buffer-create new-name)))
1214 (insert-buffer-substring the-buf p-beg p-end)
1215 (goto-char (point-min))
1216 (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1224 (mime-raw-find-entity-from-node-id entity-node-id))
1227 (mime-entity-point-min ci)
1228 (mime-entity-point-max ci)
1230 (std11-header-string-except
1232 (apply (function regexp-or) fields)
1235 (eq (mime-entity-media-type ci) 'message)
1236 (eq (mime-entity-media-subtype ci) 'rfc822))
1242 (setq fields (std11-collect-field-names)
1243 entity-node-id (cdr entity-node-id))
1246 (let ((rest mime-view-following-required-fields-list))
1248 (let ((field-name (car rest)))
1249 (or (std11-field-body field-name)
1255 (set-buffer the-buf)
1256 (set-buffer mime-mother-buffer)
1257 (set-buffer mime-raw-buffer)
1258 (std11-field-body field-name)
1262 (setq rest (cdr rest))
1264 (eword-decode-header)
1266 (let ((f (cdr (assq mode mime-view-following-method-alist))))
1271 "Sorry, following method for %s is not implemented yet."
1280 (defun mime-preview-display-x-face ()
1282 (save-window-excursion
1283 (set-buffer mime-raw-buffer)
1284 (mime-view-x-face-function)
1291 (defun mime-preview-move-to-upper ()
1292 "Move to upper entity.
1293 If there is no upper entity, call function `mime-preview-quit'."
1296 (while (null (setq cinfo
1297 (get-text-property (point) 'mime-view-entity)))
1300 (let ((r (mime-raw-find-entity-from-node-id
1301 (cdr (mime-entity-node-id cinfo))
1302 (get-text-property 1 'mime-view-entity)))
1305 (while (setq point (previous-single-property-change
1306 (point) 'mime-view-entity))
1308 (if (eq r (get-text-property (point) 'mime-view-entity))
1315 (defun mime-preview-move-to-previous ()
1316 "Move to previous entity.
1317 If there is no previous entity, it calls function registered in
1318 variable `mime-preview-over-to-previous-method-alist'."
1320 (while (null (get-text-property (point) 'mime-view-entity))
1323 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1325 (if (get-text-property (1- point) 'mime-view-entity)
1327 (goto-char (1- point))
1328 (mime-preview-move-to-previous)
1330 (let ((f (assq (mime-preview-original-major-mode)
1331 mime-preview-over-to-previous-method-alist)))
1337 (defun mime-preview-move-to-next ()
1338 "Move to next entity.
1339 If there is no previous entity, it calls function registered in
1340 variable `mime-preview-over-to-next-method-alist'."
1342 (while (null (get-text-property (point) 'mime-view-entity))
1345 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1349 (if (null (get-text-property point 'mime-view-entity))
1350 (mime-preview-move-to-next)
1352 (let ((f (assq (mime-preview-original-major-mode)
1353 mime-preview-over-to-next-method-alist)))
1359 (defun mime-preview-scroll-up-entity (&optional h)
1360 "Scroll up current entity.
1361 If reached to (point-max), it calls function registered in variable
1362 `mime-preview-over-to-next-method-alist'."
1365 (setq h (1- (window-height)))
1367 (if (= (point) (point-max))
1368 (let ((f (assq (mime-preview-original-major-mode)
1369 mime-preview-over-to-next-method-alist)))
1374 (or (next-single-property-change (point) 'mime-view-entity)
1377 (if (> (point) point)
1382 (defun mime-preview-scroll-down-entity (&optional h)
1383 "Scroll down current entity.
1384 If reached to (point-min), it calls function registered in variable
1385 `mime-preview-over-to-previous-method-alist'."
1388 (setq h (1- (window-height)))
1390 (if (= (point) (point-min))
1391 (let ((f (assq (mime-preview-original-major-mode)
1392 mime-preview-over-to-previous-method-alist)))
1397 (or (previous-single-property-change (point) 'mime-view-entity)
1399 (forward-line (- h))
1400 (if (< (point) point)
1404 (defun mime-preview-next-line-entity ()
1406 (mime-preview-scroll-up-entity 1)
1409 (defun mime-preview-previous-line-entity ()
1411 (mime-preview-scroll-down-entity 1)
1418 (defun mime-preview-quit ()
1419 "Quit from MIME-preview buffer.
1420 It calls function registered in variable
1421 `mime-preview-quitting-method-alist'."
1423 (let ((r (assq (mime-preview-original-major-mode)
1424 mime-preview-quitting-method-alist)))
1429 (defun mime-preview-kill-buffer ()
1431 (kill-buffer (current-buffer))
1438 (provide 'mime-view)
1440 (run-hooks 'mime-view-load-hook)
1442 ;;; mime-view.el ends here