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 ;;; @ buffer local variables
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.
77 Following is a list of slots of the structure:
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)
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)
96 (defvar mime-preview-buffer nil
97 "MIME-preview buffer corresponding with the (raw) buffer.")
98 (make-variable-buffer-local 'mime-preview-buffer)
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
106 Notice that this variable is usually used as buffer local variable in
109 (make-variable-buffer-local 'mime-raw-representation-type)
111 (defvar mime-raw-representation-type-alist
112 '((mime-show-message-mode . binary)
113 (mime-temp-message-mode . binary)
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.")
124 ;;; @@ in preview-buffer
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)
133 (defvar mime-raw-buffer nil
134 "Raw buffer corresponding with the (MIME-preview) buffer.")
135 (make-variable-buffer-local 'mime-raw-buffer)
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)
142 ;;; @ entity information
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))
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."
157 (setq message-info mime-raw-message-info))
158 (if (eq entity-number t)
160 (let ((sn (car entity-number)))
163 (let ((rc (nth sn (mime-entity-children message-info))))
165 (mime-raw-find-entity-from-number (cdr entity-number) rc)
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."
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)))
181 (mime-raw-find-entity-from-point point (car children))))
185 (setq children (cdr children)))
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))
197 (set-buffer (mime-entity-buffer entity))
198 mime-raw-message-info))))
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))
207 (set-buffer (mime-entity-buffer entity))
212 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
214 (defun mime-raw-get-uu-filename ()
216 (if (re-search-forward "^begin [0-9]+ " nil t)
217 (if (looking-at ".+$")
218 (buffer-substring (match-beginning 0)(match-end 0))
221 (defun mime-raw-get-subject (entity)
222 (or (std11-find-field-body '("Content-Description" "Subject"))
223 (let ((ret (mime-entity-content-disposition entity)))
225 (setq ret (mime-content-disposition-filename ret))
226 (std11-strip-quoted-string ret)
228 (let ((ret (mime-entity-content-type entity)))
232 (let ((param (mime-content-type-parameters ret)))
233 (or (assoc "name" param)
234 (assoc "x-name" param))
236 (std11-strip-quoted-string ret)
238 (if (member (mime-entity-encoding entity)
239 mime-view-uuencode-encoding-name-list)
240 (mime-raw-get-uu-filename))
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)))
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)))
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."
261 (setq message-info mime-raw-message-info))
262 (let ((dest (list message-info))
263 (rcl (mime-entity-children message-info)))
265 (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
266 (setq rcl (cdr rcl)))
270 ;;; @ presentation of preview
276 ;;; @@@ predicate function
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)
290 (not (eq (mime-entity-media-subtype mother-entity)
295 ;;; @@@ entity button generator
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)))
303 (let ((access-type (assoc "access-type" params))
304 (num (or (cdr (assoc "x-part-number" params))
305 (if (consp entity-node-id)
308 (format "%s" (1+ num))
310 (reverse entity-node-id) ".")
314 (let ((server (assoc "server" params)))
315 (setq access-type (cdr access-type))
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)))
322 (format "%s %s ([%s] %s:%s)"
323 num subject access-type site dir)
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)))
334 (format " <%s/%s%s%s>"
335 media-type media-subtype
337 (concat "; " charset)
340 (concat " (" encoding ")")
342 (if (>= (+ (current-column)(length rest))(window-width))
346 (function mime-preview-play-current-entity))
353 ;;; @@@ entity header filter
356 (defvar mime-view-content-header-filter-alist nil)
358 (defun mime-view-default-content-header-filter ()
359 (mime-view-cut-header)
360 (eword-decode-header)
363 ;;; @@@ entity field cutter
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"
372 "All fields that match this list will be hidden in MIME preview buffer.
373 Each elements are regexp of field-name.")
375 (defvar mime-view-ignored-field-regexp
377 (apply (function regexp-or) mime-view-ignored-field-list)
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.")
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))
389 (name (buffer-substring beg end))
392 (let ((rest mime-view-visible-field-list))
394 (if (string-match (car rest) name)
397 (setq rest (cdr rest))))
400 (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
409 ;;; @@@ predicate function
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)
420 (define-calist-field-match-method
421 'header #'mime-calist::field-match-method-as-default-rule)
423 (define-calist-field-match-method
424 'body #'mime-calist::field-match-method-as-default-rule)
427 (defvar mime-preview-condition nil
428 "Condition-tree about how to display entity.")
430 (ctree-set-calist-strictly
431 'mime-preview-condition '((type . application)(subtype . octet-stream)
434 (ctree-set-calist-strictly
435 'mime-preview-condition '((type . application)(subtype . octet-stream)
438 (ctree-set-calist-strictly
439 'mime-preview-condition '((type . application)(subtype . octet-stream)
443 (ctree-set-calist-strictly
444 'mime-preview-condition '((type . application)(subtype . pgp)
447 (ctree-set-calist-strictly
448 'mime-preview-condition '((type . application)(subtype . x-latex)
451 (ctree-set-calist-strictly
452 'mime-preview-condition '((type . application)(subtype . x-selection)
455 (ctree-set-calist-strictly
456 'mime-preview-condition '((type . application)(subtype . x-comment)
459 (ctree-set-calist-strictly
460 'mime-preview-condition '((type . message)(subtype . delivery-status)
463 (ctree-set-calist-strictly
464 'mime-preview-condition
466 (body-presentation-method . mime-preview-text/plain)))
468 (ctree-set-calist-strictly
469 'mime-preview-condition
472 (body-presentation-method . mime-preview-text/plain)))
474 (ctree-set-calist-strictly
475 'mime-preview-condition
476 '((type . text)(subtype . enriched)
478 (body-presentation-method . mime-preview-text/enriched)))
480 (ctree-set-calist-strictly
481 'mime-preview-condition
482 '((type . text)(subtype . richtext)
484 (body-presentation-method . mime-preview-text/richtext)))
486 (ctree-set-calist-strictly
487 'mime-preview-condition
488 '((type . text)(subtype . t)
490 (body-presentation-method . mime-preview-text/plain)))
492 (ctree-set-calist-strictly
493 'mime-preview-condition
494 '((type . multipart)(subtype . alternative)
496 (body-presentation-method . mime-preview-multipart/alternative)))
498 (ctree-set-calist-strictly
499 'mime-preview-condition '((type . message)(subtype . partial)
500 (body-presentation-method
501 . mime-preview-message/partial-button)))
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))))
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))))
516 ;;; @@@ entity presentation
519 (autoload 'mime-preview-text/plain "mime-text")
520 (autoload 'mime-preview-text/enriched "mime-text")
521 (autoload 'mime-preview-text/richtext "mime-text")
523 (defvar mime-view-announcement-for-message/partial
524 (if (and (>= emacs-major-version 19) window-system)
526 \[[ This is message/partial style split message. ]]
527 \[[ Please press `v' key in this buffer ]]
528 \[[ or click here by mouse button-2. ]]"
530 \[[ This is message/partial style split message. ]]
531 \[[ Please press `v' key in this buffer. ]]"
534 (defun mime-preview-message/partial-button (&optional entity situation)
536 (goto-char (point-max))
537 (if (not (search-backward "\n\n" nil t))
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)
547 (defun mime-preview-multipart/mixed (entity situation)
548 (let ((children (mime-entity-children entity))
550 (cdr (assq 'childrens-situation situation))))
552 (mime-view-display-entity (car children)
554 (set-buffer (mime-entity-buffer entity))
555 mime-raw-message-info)
558 (setq children (cdr children))
561 (defcustom mime-view-type-subtype-score-alist
562 '(((text . enriched) . 3)
563 ((text . richtext) . 2)
566 "Alist MEDIA-TYPE vs corresponding score.
567 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
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))
576 (defun mime-preview-multipart/alternative (entity situation)
577 (let* ((children (mime-entity-children entity))
579 (cdr (assq 'childrens-situation situation)))
587 (or (ctree-match-calist
588 mime-preview-condition
589 (append (mime-entity-situation child)
592 (if (cdr (assq 'body-presentation-method situation))
597 (cdr (assq 'type situation))
598 (cdr (assq 'subtype situation)))
599 mime-view-type-subtype-score-alist)
601 (cdr (assq 'type situation))
602 mime-view-type-subtype-score-alist)
605 mime-view-type-subtype-score-alist)
607 (if (> score max-score)
617 (let ((child (car children))
618 (situation (car situations)))
619 (mime-view-display-entity child
621 (set-buffer (mime-entity-buffer child))
622 mime-raw-message-info)
627 (del-alist 'body-presentation-method
628 (copy-alist situation))))
630 (setq children (cdr children)
631 situations (cdr situations)
636 ;;; @ acting-condition
639 (defvar mime-acting-condition nil
640 "Condition-tree about how to process entity.")
642 (if (file-readable-p mailcap-file)
643 (let ((entries (mailcap-parse-file)))
645 (let ((entry (car entries))
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))))
655 (setq entry (cdr entry))
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)))))
662 (ctree-set-calist-with-default
663 'mime-acting-condition
665 (list '(mode . "print")(cons 'method (cdr view))))
668 (setq entries (cdr entries))
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
678 (method . mime-method-to-save)))
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)
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)
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)
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)
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)
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)
712 ;; (ctree-set-calist-strictly
713 ;; 'mime-acting-condition
714 ;; '((type . image)(mode . "play")
715 ;; (method "tm-image" nil 'file "" 'encoding 'mode 'name)
717 ;; (ctree-set-calist-strictly
718 ;; 'mime-acting-condition
719 ;; '((type . image)(mode . "print")
720 ;; (method "tm-image" nil 'file "" 'encoding 'mode 'name)
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)
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)
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)
740 (ctree-set-calist-strictly
741 'mime-acting-condition
742 '((type . message)(subtype . rfc822)(mode . "play")
743 (method . mime-method-to-display-message/rfc822)
745 (ctree-set-calist-strictly
746 'mime-acting-condition
747 '((type . message)(subtype . partial)(mode . "play")
748 (method . mime-method-to-store-message/partial)
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)
758 (ctree-set-calist-strictly
759 'mime-acting-condition
760 '((type . application)(subtype . octet-stream)
761 (method . mime-method-to-save)
765 ;;; @ quitting method
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.")
773 (defvar mime-view-over-to-previous-method-alist nil)
774 (defvar mime-view-over-to-next-method-alist nil)
776 (defvar mime-view-show-summary-method nil
777 "Alist of major-mode vs. show-summary-method.")
780 ;;; @ following method
783 (defvar mime-view-following-method-alist nil
784 "Alist of major-mode vs. following-method of mime-view.")
786 (defvar mime-view-following-required-fields-list
793 ;; hack from Gnus 5.0.4.
795 (defvar mime-view-x-face-to-pbm-command
796 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
798 (defvar mime-view-x-face-command
799 (concat mime-view-x-face-to-pbm-command
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.")
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>
810 (narrow-to-region (point-min) (re-search-forward "^$" nil t))
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))
817 (call-process-region beg end "sh" nil 0 nil
818 "-c" mime-view-x-face-command)
825 (defun mime-view-display-entity (entity message-info obuf
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)
835 (setq end-of-header (if (re-search-forward "^$" nil t)
838 (if (> end-of-header end)
839 (setq end-of-header end)
842 (narrow-to-region start end)
843 (setq subj (eword-decode-string (mime-raw-get-subject entity)))
847 (or (ctree-match-calist mime-preview-condition
848 (append (mime-entity-situation entity)
851 (let ((button-is-invisible
852 (eq (cdr (assq 'entity-button situation)) 'invisible))
854 (eq (cdr (assq 'header situation)) 'visible))
855 (body-presentation-method
856 (cdr (assq 'body-presentation-method situation)))
857 (children (mime-entity-children entity)))
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)
865 (if header-is-visible
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))))
873 (mime-view-default-content-header-filter)
875 (run-hooks 'mime-view-content-header-filter-hook)
877 (cond ((eq body-presentation-method 'with-filter)
878 (let ((body-filter (cdr (assq 'body-filter situation))))
880 (narrow-to-region (point-max)(point-max))
881 (insert-buffer-substring raw-buffer end-of-header end)
882 (funcall body-filter situation)
885 ((functionp body-presentation-method)
886 (funcall body-presentation-method entity situation)
889 (when button-is-invisible
890 (goto-char (point-max))
891 (mime-view-insert-entity-button entity subj)
893 (or header-is-visible
895 (goto-char (point-max))
899 (setq ne (point-max))
901 (put-text-property nb ne 'mime-view-raw-buffer raw-buffer)
902 (put-text-property nb ne 'mime-view-entity entity)
905 (if (functionp body-presentation-method)
906 (funcall body-presentation-method entity situation)
907 (mime-preview-multipart/mixed entity situation)
912 ;;; @ MIME viewer mode
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)
927 "Menu for MIME Viewer")
929 (cond (running-xemacs
930 (defvar mime-view-xemacs-popup-menu
931 (cons mime-view-menu-title
934 (vector (nth 1 item)(nth 2 item) t)
936 mime-view-menu-list)))
937 (defun mime-view-xemacs-popup-menu (event)
938 "Popup the menu in the MIME Viewer buffer"
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)
946 (defvar mouse-button-2 [mouse-2])
949 (defun mime-view-define-keymap (&optional default)
950 (let ((mime-view-mode-map (if (keymapp default)
951 (copy-keymap default)
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)
1005 (setq mime-view-mode-map
1006 (append mime-view-mode-map (list (cons t default))))
1009 (define-key mime-view-mode-map
1010 mouse-button-2 (function mime-button-dispatcher))
1012 (cond (running-xemacs
1013 (define-key mime-view-mode-map
1014 mouse-button-3 (function mime-view-xemacs-popup-menu))
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)))
1022 (define-key mime-view-mode-map
1023 (vector 'menu-bar 'mime-view (car item))
1024 (cons (nth 1 item)(nth 2 item))
1027 (reverse mime-view-menu-list)
1030 (use-local-map mime-view-mode-map)
1031 (run-hooks 'mime-view-define-keymap-hook)
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)))
1041 (let ((win (get-buffer-window buf)))
1048 (defvar mime-view-redisplay nil)
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)))
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)
1065 (setq mime-raw-buffer raw-buffer)
1067 (setq mime-mother-buffer mother)
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
1074 '((entity-button . invisible)
1077 (mime-view-define-keymap default-keymap-or-function)
1079 (next-single-property-change (point-min) 'mime-view-entity)))
1082 (goto-char (point-min))
1083 (search-forward "\n\n" nil t)
1085 (run-hooks 'mime-view-mode-hook)
1087 (set-buffer-modified-p nil)
1088 (setq buffer-read-only t)
1091 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1092 default-keymap-or-function)
1094 (mime-view-display-message
1096 (if raw-buffer (set-buffer raw-buffer))
1097 (mime-parse-message)
1099 preview-buffer mother default-keymap-or-function))
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.
1106 Here is a list of the standard keys for mime-view-mode.
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.
1124 button-2 Move to point under the mouse cursor
1125 and decode current content as `play mode'
1128 (mime-view-display-message
1130 (if raw-buffer (set-buffer raw-buffer))
1131 (or mime-view-redisplay
1132 (mime-parse-message ctl encoding))
1134 preview-buffer mother default-keymap-or-function))
1140 (autoload 'mime-preview-play-current-entity "mime-play"
1141 "Play current entity." t)
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'."
1149 (mime-preview-play-current-entity "extract")
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'."
1158 (mime-preview-play-current-entity "print")
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)
1171 (set-buffer mime-mother-buffer)
1172 (mime-preview-original-major-mode recursive)
1177 (get-text-property (point-min) 'mime-view-entity)))
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'."
1186 (while (null (setq entity
1187 (get-text-property (point) 'mime-view-entity)))
1191 (previous-single-property-change (point) 'mime-view-entity))
1193 (entity-node-id (mime-entity-node-id entity))
1194 (len (length entity-node-id))
1198 (if (eq (next-single-property-change (point-min)
1204 ((eq (next-single-property-change p-beg 'mime-view-entity)
1206 (setq p-beg (point))
1208 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1210 (setq p-end (point-max))
1212 ((null entity-node-id)
1213 (setq p-end (point-max))
1221 (next-single-property-change
1222 (point) 'mime-view-entity))
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))
1233 (setq p-end (point-max))
1236 (let* ((mode (mime-preview-original-major-mode 'recursive))
1238 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1240 (the-buf (current-buffer))
1241 (a-buf mime-raw-buffer)
1244 (set-buffer (setq new-buf (get-buffer-create new-name)))
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)
1256 (mime-raw-find-entity-from-node-id entity-node-id))
1259 (mime-entity-point-min ci)
1260 (mime-entity-point-max ci)
1262 (std11-header-string-except
1264 (apply (function regexp-or) fields)
1267 (eq (mime-entity-media-type ci) 'message)
1268 (eq (mime-entity-media-subtype ci) 'rfc822))
1274 (setq fields (std11-collect-field-names)
1275 entity-node-id (cdr entity-node-id))
1278 (let ((rest mime-view-following-required-fields-list))
1280 (let ((field-name (car rest)))
1281 (or (std11-field-body field-name)
1287 (set-buffer the-buf)
1288 (set-buffer mime-mother-buffer)
1289 (set-buffer mime-raw-buffer)
1290 (std11-field-body field-name)
1294 (setq rest (cdr rest))
1296 (eword-decode-header)
1298 (let ((f (cdr (assq mode mime-view-following-method-alist))))
1303 "Sorry, following method for %s is not implemented yet."
1312 (defun mime-preview-display-x-face ()
1314 (save-window-excursion
1315 (set-buffer mime-raw-buffer)
1316 (mime-view-x-face-function)
1323 (defun mime-preview-move-to-upper ()
1324 "Move to upper entity.
1325 If there is no upper entity, call function `mime-preview-quit'."
1328 (while (null (setq cinfo
1329 (get-text-property (point) 'mime-view-entity)))
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)))
1337 (while (setq point (previous-single-property-change
1338 (point) 'mime-view-entity))
1340 (if (eq r (get-text-property (point) 'mime-view-entity))
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'."
1352 (while (null (get-text-property (point) 'mime-view-entity))
1355 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1357 (if (get-text-property (1- point) 'mime-view-entity)
1359 (goto-char (1- point))
1360 (mime-preview-move-to-previous)
1362 (let ((f (assq (mime-preview-original-major-mode)
1363 mime-view-over-to-previous-method-alist)))
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'."
1374 (while (null (get-text-property (point) 'mime-view-entity))
1377 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1381 (if (null (get-text-property point 'mime-view-entity))
1382 (mime-preview-move-to-next)
1384 (let ((f (assq (mime-preview-original-major-mode)
1385 mime-view-over-to-next-method-alist)))
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'."
1397 (setq h (1- (window-height)))
1399 (if (= (point) (point-max))
1400 (let ((f (assq (mime-preview-original-major-mode)
1401 mime-view-over-to-next-method-alist)))
1406 (or (next-single-property-change (point) 'mime-view-entity)
1409 (if (> (point) point)
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'."
1420 (setq h (1- (window-height)))
1422 (if (= (point) (point-min))
1423 (let ((f (assq (mime-preview-original-major-mode)
1424 mime-view-over-to-previous-method-alist)))
1429 (or (previous-single-property-change (point) 'mime-view-entity)
1431 (forward-line (- h))
1432 (if (< (point) point)
1436 (defun mime-preview-next-line-entity ()
1438 (mime-preview-scroll-up-entity 1)
1441 (defun mime-preview-previous-line-entity ()
1443 (mime-preview-scroll-down-entity 1)
1450 (defun mime-preview-quit ()
1451 "Quit from MIME-preview buffer.
1452 It calls function registered in variable
1453 `mime-preview-quitting-method-alist'."
1455 (let ((r (assq (mime-preview-original-major-mode)
1456 mime-preview-quitting-method-alist)))
1461 (defun mime-preview-show-summary ()
1463 It calls function registered in variable
1464 `mime-view-show-summary-method'."
1466 (let ((r (assq (mime-preview-original-major-mode)
1467 mime-view-show-summary-method)))
1472 (defun mime-preview-kill-buffer ()
1474 (kill-buffer (current-buffer))
1481 (provide 'mime-view)
1483 (run-hooks 'mime-view-load-hook)
1485 ;;; mime-view.el ends here