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-major-mode nil
138 "Major-mode of mime-raw-buffer.")
139 (make-variable-buffer-local 'mime-preview-original-major-mode)
141 (defvar mime-preview-original-window-configuration nil
142 "Window-configuration before mime-view-mode is called.")
143 (make-variable-buffer-local 'mime-preview-original-window-configuration)
146 ;;; @ entity information
149 (defsubst mime-raw-find-entity-from-node-id (entity-node-id
150 &optional message-info)
151 "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
152 If optional argument MESSAGE-INFO is not specified,
153 `mime-raw-message-info' is used."
154 (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
156 (defun mime-raw-find-entity-from-number (entity-number &optional message-info)
157 "Return entity from ENTITY-NUMBER in mime-raw-buffer.
158 If optional argument MESSAGE-INFO is not specified,
159 `mime-raw-message-info' is used."
161 (setq message-info mime-raw-message-info))
162 (if (eq entity-number t)
164 (let ((sn (car entity-number)))
167 (let ((rc (nth sn (mime-entity-children message-info))))
169 (mime-raw-find-entity-from-number (cdr entity-number) rc)
173 (defun mime-raw-find-entity-from-point (point &optional message-info)
174 "Return entity from POINT in mime-raw-buffer.
175 If optional argument MESSAGE-INFO is not specified,
176 `mime-raw-message-info' is used."
178 (setq message-info mime-raw-message-info))
179 (if (and (<= (mime-entity-point-min message-info) point)
180 (<= point (mime-entity-point-max message-info)))
181 (let ((children (mime-entity-children message-info)))
185 (mime-raw-find-entity-from-point point (car children))))
189 (setq children (cdr children)))
192 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
193 "Return entity-node-id from POINT in mime-raw-buffer.
194 If optional argument MESSAGE-INFO is not specified,
195 `mime-raw-message-info' is used."
196 (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
198 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
199 "Return entity-number from POINT in mime-raw-buffer.
200 If optional argument MESSAGE-INFO is not specified,
201 `mime-raw-message-info' is used."
202 (reverse (mime-raw-point-to-entity-node-id point message-info)))
204 (defsubst mime-raw-entity-parent (entity &optional message-info)
205 "Return mother entity of ENTITY.
206 If optional argument MESSAGE-INFO is not specified,
207 `mime-raw-message-info' is used."
208 (mime-raw-find-entity-from-node-id (cdr (mime-entity-node-id entity))
211 (defun mime-raw-flatten-message-info (&optional message-info)
212 "Return list of entity in mime-raw-buffer.
213 If optional argument MESSAGE-INFO is not specified,
214 `mime-raw-message-info' is used."
216 (setq message-info mime-raw-message-info))
217 (let ((dest (list message-info))
218 (rcl (mime-entity-children message-info)))
220 (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
221 (setq rcl (cdr rcl)))
225 ;;; @ presentation of preview
231 ;;; @@@ predicate function
234 (defun mime-view-entity-button-visible-p (entity message-info)
235 "Return non-nil if header of ENTITY is visible.
236 Please redefine this function if you want to change default setting."
237 (let ((media-type (mime-entity-media-type entity))
238 (media-subtype (mime-entity-media-subtype entity)))
239 (or (not (eq media-type 'application))
240 (and (not (eq media-subtype 'x-selection))
241 (or (not (eq media-subtype 'octet-stream))
243 (mime-raw-entity-parent entity message-info)))
244 (or (not (eq (mime-entity-media-type mother-entity)
246 (not (eq (mime-entity-media-subtype mother-entity)
251 ;;; @@@ entity button generator
254 (defun mime-view-insert-entity-button (entity message-info subj)
255 "Insert entity-button of ENTITY."
256 (let ((entity-node-id (mime-entity-node-id entity))
257 (params (mime-entity-parameters entity)))
259 (let ((access-type (assoc "access-type" params))
260 (num (or (cdr (assoc "x-part-number" params))
261 (if (consp entity-node-id)
264 (format "%s" (1+ num))
266 (reverse entity-node-id) ".")
270 (let ((server (assoc "server" params)))
271 (setq access-type (cdr access-type))
273 (format "%s %s ([%s] %s)"
274 num subj access-type (cdr server))
275 (let ((site (cdr (assoc "site" params)))
276 (dir (cdr (assoc "directory" params)))
278 (format "%s %s ([%s] %s:%s)"
279 num subj access-type site dir)
283 (let ((media-type (mime-entity-media-type entity))
284 (media-subtype (mime-entity-media-subtype entity))
285 (charset (cdr (assoc "charset" params)))
286 (encoding (mime-entity-encoding entity)))
290 (format " <%s/%s%s%s>"
291 media-type media-subtype
293 (concat "; " charset)
296 (concat " (" encoding ")")
298 (if (>= (+ (current-column)(length rest))(window-width))
302 (function mime-preview-play-current-entity))
309 ;;; @@@ entity header filter
312 (defvar mime-view-content-header-filter-alist nil)
314 (defun mime-view-default-content-header-filter ()
315 (mime-view-cut-header)
316 (eword-decode-header)
319 ;;; @@@ entity field cutter
322 (defvar mime-view-ignored-field-list
323 '(".*Received" ".*Path" ".*Id" "References"
324 "Replied" "Errors-To"
325 "Lines" "Sender" ".*Host" "Xref"
326 "Content-Type" "Precedence"
328 "All fields that match this list will be hidden in MIME preview buffer.
329 Each elements are regexp of field-name.")
331 (defvar mime-view-ignored-field-regexp
333 (apply (function regexp-or) mime-view-ignored-field-list)
336 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
337 "All fields that match this list will be displayed in MIME preview buffer.
338 Each elements are regexp of field-name.")
340 (defun mime-view-cut-header ()
341 (goto-char (point-min))
342 (while (re-search-forward mime-view-ignored-field-regexp nil t)
343 (let* ((beg (match-beginning 0))
345 (name (buffer-substring beg end))
348 (let ((rest mime-view-visible-field-list))
350 (if (string-match (car rest) name)
353 (setq rest (cdr rest))))
356 (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
365 ;;; @@@ predicate function
368 (defun mime-calist::field-match-method-as-default-rule (calist
369 field-type field-value)
370 (let ((s-field (assq field-type calist)))
371 (cond ((null s-field)
372 (cons (cons field-type field-value) calist)
376 (define-calist-field-match-method
377 'header #'mime-calist::field-match-method-as-default-rule)
379 (define-calist-field-match-method
380 'body #'mime-calist::field-match-method-as-default-rule)
383 (defvar mime-preview-condition nil
384 "Condition-tree about how to display entity.")
386 (ctree-set-calist-strictly
387 'mime-preview-condition '((type . application)(subtype . octet-stream)
390 (ctree-set-calist-strictly
391 'mime-preview-condition '((type . application)(subtype . octet-stream)
394 (ctree-set-calist-strictly
395 'mime-preview-condition '((type . application)(subtype . octet-stream)
399 (ctree-set-calist-strictly
400 'mime-preview-condition '((type . application)(subtype . pgp)
403 (ctree-set-calist-strictly
404 'mime-preview-condition '((type . application)(subtype . x-latex)
407 (ctree-set-calist-strictly
408 'mime-preview-condition '((type . application)(subtype . x-selection)
411 (ctree-set-calist-strictly
412 'mime-preview-condition '((type . application)(subtype . x-comment)
415 (ctree-set-calist-strictly
416 'mime-preview-condition '((type . message)(subtype . delivery-status)
419 (ctree-set-calist-strictly
420 'mime-preview-condition
422 (body-presentation-method . mime-preview-text/plain)))
424 (ctree-set-calist-strictly
425 'mime-preview-condition
428 (body-presentation-method . mime-preview-text/plain)))
430 (ctree-set-calist-strictly
431 'mime-preview-condition
432 '((type . text)(subtype . enriched)
434 (body-presentation-method . mime-preview-text/enriched)))
436 (ctree-set-calist-strictly
437 'mime-preview-condition
438 '((type . text)(subtype . richtext)
440 (body-presentation-method . mime-preview-text/richtext)))
442 (ctree-set-calist-strictly
443 'mime-preview-condition
444 '((type . text)(subtype . t)
446 (body-presentation-method . mime-preview-text/plain)))
448 (ctree-set-calist-strictly
449 'mime-preview-condition
450 '((type . multipart)(subtype . alternative)
452 (body-presentation-method . mime-preview-multipart/alternative)))
454 (ctree-set-calist-strictly
455 'mime-preview-condition '((type . message)(subtype . partial)
456 (body-presentation-method
457 . mime-preview-message/partial-button)))
459 (ctree-set-calist-strictly
460 'mime-preview-condition '((type . message)(subtype . rfc822)
461 (body-presentation-method . nil)
462 (childrens-situation (header . visible)
463 (entity-button . invisible))))
465 (ctree-set-calist-strictly
466 'mime-preview-condition '((type . message)(subtype . news)
467 (body-presentation-method . nil)
468 (childrens-situation (header . visible)
469 (entity-button . invisible))))
472 ;;; @@@ entity presentation
475 (autoload 'mime-preview-text/plain "mime-text")
476 (autoload 'mime-preview-text/enriched "mime-text")
477 (autoload 'mime-preview-text/richtext "mime-text")
479 (defvar mime-view-announcement-for-message/partial
480 (if (and (>= emacs-major-version 19) window-system)
482 \[[ This is message/partial style split message. ]]
483 \[[ Please press `v' key in this buffer ]]
484 \[[ or click here by mouse button-2. ]]"
486 \[[ This is message/partial style split message. ]]
487 \[[ Please press `v' key in this buffer. ]]"
490 (defun mime-preview-message/partial-button (&optional entity situation)
492 (goto-char (point-max))
493 (if (not (search-backward "\n\n" nil t))
496 (goto-char (point-max))
497 (narrow-to-region (point-max)(point-max))
498 (insert mime-view-announcement-for-message/partial)
499 (mime-add-button (point-min)(point-max)
500 #'mime-preview-play-current-entity)
503 (defun mime-preview-multipart/mixed (entity situation)
504 (let ((children (mime-entity-children entity))
506 (cdr (assq 'childrens-situation situation))))
508 (mime-view-display-entity (car children)
510 (set-buffer mime-raw-buffer)
511 mime-raw-message-info)
512 mime-raw-buffer (current-buffer)
514 (setq children (cdr children))
517 (defcustom mime-view-type-subtype-score-alist
518 '(((text . enriched) . 3)
519 ((text . richtext) . 2)
522 "Alist MEDIA-TYPE vs corresponding score.
523 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
525 :type '(repeat (cons (choice :tag "Media-Type"
526 (item :tag "Type/Subtype"
527 (cons symbol symbol))
528 (item :tag "Type" symbol)
529 (item :tag "Default" t))
532 (defun mime-preview-multipart/alternative (entity situation)
533 (let* ((children (mime-entity-children entity))
535 (cdr (assq 'childrens-situation situation)))
543 (or (ctree-match-calist
544 mime-preview-condition
546 (or (mime-entity-content-type child)
547 (make-mime-content-type 'text 'plain))
548 (list* (cons 'encoding
549 (mime-entity-encoding child))
550 (cons 'major-mode major-mode)
553 (if (cdr (assq 'body-presentation-method situation))
558 (cdr (assq 'type situation))
559 (cdr (assq 'subtype situation)))
560 mime-view-type-subtype-score-alist)
562 (cdr (assq 'type situation))
563 mime-view-type-subtype-score-alist)
566 mime-view-type-subtype-score-alist)
568 (if (> score max-score)
578 (let ((situation (car situations)))
579 (mime-view-display-entity (car children)
581 (set-buffer mime-raw-buffer)
582 mime-raw-message-info)
583 mime-raw-buffer (current-buffer)
587 (del-alist 'body-presentation-method
588 (copy-alist situation))))
590 (setq children (cdr children)
591 situations (cdr situations)
596 ;;; @ acting-condition
599 (defvar mime-acting-condition nil
600 "Condition-tree about how to process entity.")
602 (if (file-readable-p mailcap-file)
603 (let ((entries (mailcap-parse-file)))
605 (let ((entry (car entries))
608 (let* ((field (car entry))
609 (field-type (car field)))
610 (cond ((eq field-type 'view) (setq view field))
611 ((eq field-type 'print) (setq print field))
612 ((memq field-type '(compose composetyped edit)))
613 (t (setq shared (cons field shared))))
615 (setq entry (cdr entry))
617 (setq shared (nreverse shared))
618 (ctree-set-calist-with-default
619 'mime-acting-condition
620 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
622 (ctree-set-calist-with-default
623 'mime-acting-condition
625 (list '(mode . "print")(cons 'method (cdr view))))
628 (setq entries (cdr entries))
631 ;; (ctree-set-calist-strictly
632 ;; 'mime-acting-condition
633 ;; '((type . t)(subtype . t)(mode . "extract")
634 ;; (method . mime-method-to-save)))
635 (ctree-set-calist-with-default
636 'mime-acting-condition
638 (method . mime-method-to-save)))
640 ;; (ctree-set-calist-strictly
641 ;; 'mime-acting-condition
642 ;; '((type . text)(subtype . plain)(mode . "play")
643 ;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name)
645 ;; (ctree-set-calist-strictly
646 ;; 'mime-acting-condition
647 ;; '((type . text)(subtype . plain)(mode . "print")
648 ;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name)
650 ;; (ctree-set-calist-strictly
651 ;; 'mime-acting-condition
652 ;; '((type . text)(subtype . html)(mode . "play")
653 ;; (method "tm-html" nil 'file "" 'encoding 'mode 'name)
655 (ctree-set-calist-strictly
656 'mime-acting-condition
657 '((type . text)(subtype . x-rot13-47)(mode . "play")
658 (method . mime-method-to-display-caesar)
660 (ctree-set-calist-strictly
661 'mime-acting-condition
662 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
663 (method . mime-method-to-display-caesar)
666 ;; (ctree-set-calist-strictly
667 ;; 'mime-acting-condition
668 ;; '((type . audio)(subtype . basic)(mode . "play")
669 ;; (method "tm-au" nil 'file "" 'encoding 'mode 'name)
672 ;; (ctree-set-calist-strictly
673 ;; 'mime-acting-condition
674 ;; '((type . image)(mode . "play")
675 ;; (method "tm-image" nil 'file "" 'encoding 'mode 'name)
677 ;; (ctree-set-calist-strictly
678 ;; 'mime-acting-condition
679 ;; '((type . image)(mode . "print")
680 ;; (method "tm-image" nil 'file "" 'encoding 'mode 'name)
683 ;; (ctree-set-calist-strictly
684 ;; 'mime-acting-condition
685 ;; '((type . video)(subtype . mpeg)(mode . "play")
686 ;; (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name)
689 ;; (ctree-set-calist-strictly
690 ;; 'mime-acting-condition
691 ;; '((type . application)(subtype . postscript)(mode . "play")
692 ;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name)
694 ;; (ctree-set-calist-strictly
695 ;; 'mime-acting-condition
696 ;; '((type . application)(subtype . postscript)(mode . "print")
697 ;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name)
700 (ctree-set-calist-strictly
701 'mime-acting-condition
702 '((type . message)(subtype . rfc822)(mode . "play")
703 (method . mime-method-to-display-message/rfc822)
705 (ctree-set-calist-strictly
706 'mime-acting-condition
707 '((type . message)(subtype . partial)(mode . "play")
708 (method . mime-method-to-store-message/partial)
711 (ctree-set-calist-strictly
712 'mime-acting-condition
713 '((type . message)(subtype . external-body)
714 ("access-type" . "anon-ftp")
715 (method . mime-method-to-display-message/external-ftp)
718 (ctree-set-calist-strictly
719 'mime-acting-condition
720 '((type . application)(subtype . octet-stream)
721 (method . mime-method-to-save)
725 ;;; @ quitting method
728 (defvar mime-preview-quitting-method-alist
729 '((mime-show-message-mode
730 . mime-preview-quitting-method-for-mime-show-message-mode))
731 "Alist of major-mode vs. quitting-method of mime-view.")
733 (defvar mime-view-over-to-previous-method-alist nil)
734 (defvar mime-view-over-to-next-method-alist nil)
736 (defvar mime-view-show-summary-method nil
737 "Alist of major-mode vs. show-summary-method.")
740 ;;; @ following method
743 (defvar mime-view-following-method-alist nil
744 "Alist of major-mode vs. following-method of mime-view.")
746 (defvar mime-view-following-required-fields-list
753 ;; hack from Gnus 5.0.4.
755 (defvar mime-view-x-face-to-pbm-command
756 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
758 (defvar mime-view-x-face-command
759 (concat mime-view-x-face-to-pbm-command
761 "String to be executed to display an X-Face field.
762 The command will be executed in a sub-shell asynchronously.
763 The compressed face will be piped to this command.")
765 (defun mime-view-x-face-function ()
766 "Function to display X-Face field. You can redefine to customize."
767 ;; 1995/10/12 (c.f. tm-eng:130)
768 ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
770 (narrow-to-region (point-min) (re-search-forward "^$" nil t))
772 (goto-char (point-min))
773 (if (re-search-forward "^X-Face:[ \t]*" nil t)
774 (let ((beg (match-end 0))
775 (end (std11-field-end))
777 (call-process-region beg end "sh" nil 0 nil
778 "-c" mime-view-x-face-command)
785 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
791 (defvar mime-view-redisplay nil)
793 (defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf)
799 (or mime-view-redisplay
800 (setq mime-raw-message-info (mime-parse-message ctl encoding))
802 (let ((message-info mime-raw-message-info)
803 (the-buf (current-buffer))
806 (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
807 (set-buffer (get-buffer-create obuf))
808 (let ((inhibit-read-only t))
809 ;;(setq buffer-read-only nil)
812 (setq mime-raw-buffer the-buf)
813 (setq mime-preview-original-major-mode mode)
814 (setq major-mode 'mime-view-mode)
815 (setq mode-name "MIME-View")
816 (mime-view-display-entity message-info message-info
818 '((entity-button . invisible)
821 (set-buffer-modified-p nil)
823 (setq buffer-read-only t)
826 (setq mime-preview-buffer obuf)
829 (defun mime-view-display-entity (entity message-info ibuf obuf
832 (let* ((start (mime-entity-point-min entity))
833 (end (mime-entity-point-max entity))
834 (content-type (mime-entity-content-type entity))
835 (encoding (mime-entity-encoding entity))
836 end-of-header e nb ne subj)
839 (setq end-of-header (if (re-search-forward "^$" nil t)
842 (if (> end-of-header end)
843 (setq end-of-header end)
846 (narrow-to-region start end)
847 (setq subj (eword-decode-string (mime-raw-get-subject entity)))
851 (or (ctree-match-calist mime-preview-condition
854 (make-mime-content-type
856 (list* (cons 'encoding encoding)
857 (cons 'major-mode major-mode)
860 (let ((button-is-invisible
861 (eq (cdr (assq 'entity-button situation)) 'invisible))
863 (eq (cdr (assq 'header situation)) 'visible))
864 (body-presentation-method
865 (cdr (assq 'body-presentation-method situation)))
866 (children (mime-entity-children entity)))
869 (narrow-to-region nb nb)
870 (or button-is-invisible
871 (if (mime-view-entity-button-visible-p entity message-info)
872 (mime-view-insert-entity-button entity message-info subj)
874 (if header-is-visible
876 (narrow-to-region (point)(point))
877 (insert-buffer-substring mime-raw-buffer start end-of-header)
878 (let ((f (cdr (assq mime-preview-original-major-mode
879 mime-view-content-header-filter-alist))))
882 (mime-view-default-content-header-filter)
884 (run-hooks 'mime-view-content-header-filter-hook)
886 (cond ((eq body-presentation-method 'with-filter)
887 (let ((body-filter (cdr (assq 'body-filter situation))))
889 (narrow-to-region (point-max)(point-max))
890 (insert-buffer-substring mime-raw-buffer end-of-header end)
891 (funcall body-filter situation)
894 ((functionp body-presentation-method)
895 (funcall body-presentation-method entity situation)
898 (when button-is-invisible
899 (goto-char (point-max))
900 (mime-view-insert-entity-button entity message-info subj)
902 (or header-is-visible
904 (goto-char (point-max))
908 (setq ne (point-max))
910 (put-text-property nb ne 'mime-view-raw-buffer ibuf)
911 (put-text-property nb ne 'mime-view-entity entity)
914 (if (functionp body-presentation-method)
915 (funcall body-presentation-method entity situation)
916 (mime-preview-multipart/mixed entity situation)
920 (defun mime-raw-get-uu-filename ()
922 (if (re-search-forward "^begin [0-9]+ " nil t)
923 (if (looking-at ".+$")
924 (buffer-substring (match-beginning 0)(match-end 0))
927 (defun mime-raw-get-subject (entity)
928 (or (std11-find-field-body '("Content-Description" "Subject"))
929 (let ((ret (mime-entity-content-disposition entity)))
931 (setq ret (mime-content-disposition-filename ret))
932 (std11-strip-quoted-string ret)
934 (let ((ret (mime-entity-content-type entity)))
938 (let ((param (mime-content-type-parameters ret)))
939 (or (assoc "name" param)
940 (assoc "x-name" param))
942 (std11-strip-quoted-string ret)
944 (if (member (mime-entity-encoding entity)
945 mime-view-uuencode-encoding-name-list)
946 (mime-raw-get-uu-filename))
950 ;;; @ MIME viewer mode
953 (defconst mime-view-menu-title "MIME-View")
954 (defconst mime-view-menu-list
955 '((up "Move to upper entity" mime-preview-move-to-upper)
956 (previous "Move to previous entity" mime-preview-move-to-previous)
957 (next "Move to next entity" mime-preview-move-to-next)
958 (scroll-down "Scroll-down" mime-preview-scroll-down-entity)
959 (scroll-up "Scroll-up" mime-preview-scroll-up-entity)
960 (play "Play current entity" mime-preview-play-current-entity)
961 (extract "Extract current entity" mime-preview-extract-current-entity)
962 (print "Print current entity" mime-preview-print-current-entity)
963 (x-face "Show X Face" mime-preview-display-x-face)
965 "Menu for MIME Viewer")
967 (cond (running-xemacs
968 (defvar mime-view-xemacs-popup-menu
969 (cons mime-view-menu-title
972 (vector (nth 1 item)(nth 2 item) t)
974 mime-view-menu-list)))
975 (defun mime-view-xemacs-popup-menu (event)
976 "Popup the menu in the MIME Viewer buffer"
978 (select-window (event-window event))
979 (set-buffer (event-buffer event))
980 (popup-menu 'mime-view-xemacs-popup-menu))
981 (defvar mouse-button-2 'button2)
984 (defvar mouse-button-2 [mouse-2])
987 (defun mime-view-define-keymap (&optional default)
988 (let ((mime-view-mode-map (if (keymapp default)
989 (copy-keymap default)
992 (define-key mime-view-mode-map
993 "u" (function mime-preview-move-to-upper))
994 (define-key mime-view-mode-map
995 "p" (function mime-preview-move-to-previous))
996 (define-key mime-view-mode-map
997 "n" (function mime-preview-move-to-next))
998 (define-key mime-view-mode-map
999 "\e\t" (function mime-preview-move-to-previous))
1000 (define-key mime-view-mode-map
1001 "\t" (function mime-preview-move-to-next))
1002 (define-key mime-view-mode-map
1003 " " (function mime-preview-scroll-up-entity))
1004 (define-key mime-view-mode-map
1005 "\M- " (function mime-preview-scroll-down-entity))
1006 (define-key mime-view-mode-map
1007 "\177" (function mime-preview-scroll-down-entity))
1008 (define-key mime-view-mode-map
1009 "\C-m" (function mime-preview-next-line-entity))
1010 (define-key mime-view-mode-map
1011 "\C-\M-m" (function mime-preview-previous-line-entity))
1012 (define-key mime-view-mode-map
1013 "v" (function mime-preview-play-current-entity))
1014 (define-key mime-view-mode-map
1015 "e" (function mime-preview-extract-current-entity))
1016 (define-key mime-view-mode-map
1017 "\C-c\C-p" (function mime-preview-print-current-entity))
1018 (define-key mime-view-mode-map
1019 "a" (function mime-preview-follow-current-entity))
1020 (define-key mime-view-mode-map
1021 "q" (function mime-preview-quit))
1022 (define-key mime-view-mode-map
1023 "h" (function mime-preview-show-summary))
1024 (define-key mime-view-mode-map
1025 "\C-c\C-x" (function mime-preview-kill-buffer))
1026 ;; (define-key mime-view-mode-map
1027 ;; "<" (function beginning-of-buffer))
1028 ;; (define-key mime-view-mode-map
1029 ;; ">" (function end-of-buffer))
1030 (define-key mime-view-mode-map
1031 "?" (function describe-mode))
1032 (define-key mime-view-mode-map
1033 [tab] (function mime-preview-move-to-next))
1034 (define-key mime-view-mode-map
1035 [delete] (function mime-preview-scroll-down-entity))
1036 (define-key mime-view-mode-map
1037 [backspace] (function mime-preview-scroll-down-entity))
1038 (if (functionp default)
1039 (cond (running-xemacs
1040 (set-keymap-default-binding mime-view-mode-map default)
1043 (setq mime-view-mode-map
1044 (append mime-view-mode-map (list (cons t default))))
1047 (define-key mime-view-mode-map
1048 mouse-button-2 (function mime-button-dispatcher))
1050 (cond (running-xemacs
1051 (define-key mime-view-mode-map
1052 mouse-button-3 (function mime-view-xemacs-popup-menu))
1054 ((>= emacs-major-version 19)
1055 (define-key mime-view-mode-map [menu-bar mime-view]
1056 (cons mime-view-menu-title
1057 (make-sparse-keymap mime-view-menu-title)))
1060 (define-key mime-view-mode-map
1061 (vector 'menu-bar 'mime-view (car item))
1062 (cons (nth 1 item)(nth 2 item))
1065 (reverse mime-view-menu-list)
1068 (use-local-map mime-view-mode-map)
1069 (run-hooks 'mime-view-define-keymap-hook)
1072 (defsubst mime-maybe-hide-echo-buffer ()
1073 "Clear mime-echo buffer and delete window for it."
1074 (let ((buf (get-buffer mime-echo-buffer-name)))
1079 (let ((win (get-buffer-window buf)))
1086 (defun mime-view-mode (&optional mother ctl encoding ibuf obuf
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.
1108 button-2 Move to point under the mouse cursor
1109 and decode current content as `play mode'
1112 (mime-maybe-hide-echo-buffer)
1113 (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf))
1114 (win-conf (current-window-configuration))
1117 (switch-to-buffer ret)
1118 (setq mime-preview-original-window-configuration win-conf)
1121 (setq mime-mother-buffer mother)
1123 (mime-view-define-keymap default-keymap-or-function)
1125 (next-single-property-change (point-min) 'mime-view-entity)))
1128 (goto-char (point-min))
1129 (search-forward "\n\n" nil t)
1131 (run-hooks 'mime-view-mode-hook)
1138 (autoload 'mime-preview-play-current-entity "mime-play"
1139 "Play current entity." t)
1141 (defun mime-preview-extract-current-entity ()
1142 "Extract current entity into file (maybe).
1143 It decodes current entity to call internal or external method as
1144 \"extract\" mode. The method is selected from variable
1145 `mime-acting-condition'."
1147 (mime-preview-play-current-entity "extract")
1150 (defun mime-preview-print-current-entity ()
1151 "Print current entity (maybe).
1152 It decodes current entity to call internal or external method as
1153 \"print\" mode. The method is selected from variable
1154 `mime-acting-condition'."
1156 (mime-preview-play-current-entity "print")
1163 (defun mime-preview-original-major-mode ()
1164 "Return major-mode of original buffer.
1165 If a current buffer has mime-mother-buffer, return original major-mode
1166 of the mother-buffer."
1167 (if mime-mother-buffer
1169 (set-buffer mime-mother-buffer)
1170 (mime-preview-original-major-mode)
1172 mime-preview-original-major-mode))
1174 (defun mime-preview-follow-current-entity ()
1175 "Write follow message to current entity.
1176 It calls following-method selected from variable
1177 `mime-view-following-method-alist'."
1180 (while (null (setq entity
1181 (get-text-property (point) 'mime-view-entity)))
1185 (previous-single-property-change (point) 'mime-view-entity))
1187 (entity-node-id (mime-entity-node-id entity))
1188 (len (length entity-node-id))
1192 (if (eq (next-single-property-change (point-min)
1198 ((eq (next-single-property-change p-beg 'mime-view-entity)
1200 (setq p-beg (point))
1202 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1204 (setq p-end (point-max))
1206 ((null entity-node-id)
1207 (setq p-end (point-max))
1215 (next-single-property-change
1216 (point) 'mime-view-entity))
1218 (let ((rc (mime-entity-node-id
1219 (get-text-property (point)
1220 'mime-view-entity))))
1221 (or (equal entity-node-id
1222 (nthcdr (- (length rc) len) rc))
1227 (setq p-end (point-max))
1230 (let* ((mode (mime-preview-original-major-mode))
1232 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1234 (the-buf (current-buffer))
1235 (a-buf mime-raw-buffer)
1238 (set-buffer (setq new-buf (get-buffer-create new-name)))
1240 (insert-buffer-substring the-buf p-beg p-end)
1241 (goto-char (point-min))
1242 (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1250 (mime-raw-find-entity-from-node-id entity-node-id))
1253 (mime-entity-point-min ci)
1254 (mime-entity-point-max ci)
1256 (std11-header-string-except
1258 (apply (function regexp-or) fields)
1261 (eq (mime-entity-media-type ci) 'message)
1262 (eq (mime-entity-media-subtype ci) 'rfc822))
1268 (setq fields (std11-collect-field-names)
1269 entity-node-id (cdr entity-node-id))
1272 (let ((rest mime-view-following-required-fields-list))
1274 (let ((field-name (car rest)))
1275 (or (std11-field-body field-name)
1281 (set-buffer the-buf)
1282 (set-buffer mime-mother-buffer)
1283 (set-buffer mime-raw-buffer)
1284 (std11-field-body field-name)
1288 (setq rest (cdr rest))
1290 (eword-decode-header)
1292 (let ((f (cdr (assq mode mime-view-following-method-alist))))
1297 "Sorry, following method for %s is not implemented yet."
1306 (defun mime-preview-display-x-face ()
1308 (save-window-excursion
1309 (set-buffer mime-raw-buffer)
1310 (mime-view-x-face-function)
1317 (defun mime-preview-move-to-upper ()
1318 "Move to upper entity.
1319 If there is no upper entity, call function `mime-preview-quit'."
1322 (while (null (setq cinfo
1323 (get-text-property (point) 'mime-view-entity)))
1326 (let ((r (mime-raw-find-entity-from-node-id
1327 (cdr (mime-entity-node-id cinfo))
1328 (get-text-property 1 'mime-view-entity)))
1331 (while (setq point (previous-single-property-change
1332 (point) 'mime-view-entity))
1334 (if (eq r (get-text-property (point) 'mime-view-entity))
1341 (defun mime-preview-move-to-previous ()
1342 "Move to previous entity.
1343 If there is no previous entity, it calls function registered in
1344 variable `mime-view-over-to-previous-method-alist'."
1346 (while (null (get-text-property (point) 'mime-view-entity))
1349 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1351 (if (get-text-property (1- point) 'mime-view-entity)
1353 (goto-char (1- point))
1354 (mime-preview-move-to-previous)
1356 (let ((f (assq mime-preview-original-major-mode
1357 mime-view-over-to-previous-method-alist)))
1363 (defun mime-preview-move-to-next ()
1364 "Move to next entity.
1365 If there is no previous entity, it calls function registered in
1366 variable `mime-view-over-to-next-method-alist'."
1368 (while (null (get-text-property (point) 'mime-view-entity))
1371 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1375 (if (null (get-text-property point 'mime-view-entity))
1376 (mime-preview-move-to-next)
1378 (let ((f (assq mime-preview-original-major-mode
1379 mime-view-over-to-next-method-alist)))
1385 (defun mime-preview-scroll-up-entity (&optional h)
1386 "Scroll up current entity.
1387 If reached to (point-max), it calls function registered in variable
1388 `mime-view-over-to-next-method-alist'."
1391 (setq h (1- (window-height)))
1393 (if (= (point) (point-max))
1394 (let ((f (assq mime-preview-original-major-mode
1395 mime-view-over-to-next-method-alist)))
1400 (or (next-single-property-change (point) 'mime-view-entity)
1403 (if (> (point) point)
1408 (defun mime-preview-scroll-down-entity (&optional h)
1409 "Scroll down current entity.
1410 If reached to (point-min), it calls function registered in variable
1411 `mime-view-over-to-previous-method-alist'."
1414 (setq h (1- (window-height)))
1416 (if (= (point) (point-min))
1417 (let ((f (assq mime-preview-original-major-mode
1418 mime-view-over-to-previous-method-alist)))
1427 (previous-single-property-change (point)
1433 (setq point (point-min))
1435 (forward-line (- h))
1436 (if (< (point) point)
1440 (defun mime-preview-next-line-entity ()
1442 (mime-preview-scroll-up-entity 1)
1445 (defun mime-preview-previous-line-entity ()
1447 (mime-preview-scroll-down-entity 1)
1454 (defun mime-preview-quit ()
1455 "Quit from MIME-preview buffer.
1456 It calls function registered in variable
1457 `mime-preview-quitting-method-alist'."
1459 (let ((r (assq mime-preview-original-major-mode
1460 mime-preview-quitting-method-alist)))
1465 (defun mime-preview-show-summary ()
1467 It calls function registered in variable
1468 `mime-view-show-summary-method'."
1470 (let ((r (assq mime-preview-original-major-mode
1471 mime-view-show-summary-method)))
1476 (defun mime-preview-kill-buffer ()
1478 (kill-buffer (current-buffer))
1485 (provide 'mime-view)
1487 (run-hooks 'mime-view-load-hook)
1489 ;;; mime-view.el ends here