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 WEMI (Widget based 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 or click here by mouse button-2."
562 This is message/partial style split message.
563 Please press `v' key in this buffer."
566 (defun mime-preview-message/partial-button (&optional entity situation)
568 (goto-char (point-max))
569 (if (not (search-backward "\n\n" nil t))
572 (goto-char (point-max))
573 ;;(narrow-to-region (point-max)(point-max))
574 ;;(insert mime-view-announcement-for-message/partial)
575 ;; (mime-add-button (point-min)(point-max)
576 ;; #'mime-preview-play-current-entity)
577 (mime-insert-button mime-view-announcement-for-message/partial
578 #'mime-preview-play-current-entity)
581 (defun mime-preview-multipart/mixed (entity situation)
582 (let ((children (mime-entity-children entity))
584 (cdr (assq 'childrens-situation situation))))
586 (mime-view-display-entity (car children)
588 (set-buffer (mime-entity-buffer entity))
589 mime-raw-message-info)
592 (setq children (cdr children))
595 (defcustom mime-view-type-subtype-score-alist
596 '(((text . enriched) . 3)
597 ((text . richtext) . 2)
600 "Alist MEDIA-TYPE vs corresponding score.
601 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
603 :type '(repeat (cons (choice :tag "Media-Type"
604 (item :tag "Type/Subtype"
605 (cons symbol symbol))
606 (item :tag "Type" symbol)
607 (item :tag "Default" t))
610 (defun mime-preview-multipart/alternative (entity situation)
611 (let* ((children (mime-entity-children entity))
613 (cdr (assq 'childrens-situation situation)))
621 (or (ctree-match-calist
622 mime-preview-condition
623 (append (mime-entity-situation child)
626 (if (cdr (assq 'body-presentation-method situation))
631 (cdr (assq 'type situation))
632 (cdr (assq 'subtype situation)))
633 mime-view-type-subtype-score-alist)
635 (cdr (assq 'type situation))
636 mime-view-type-subtype-score-alist)
639 mime-view-type-subtype-score-alist)
641 (if (> score max-score)
651 (let ((child (car children))
652 (situation (car situations)))
653 (mime-view-display-entity child
655 (set-buffer (mime-entity-buffer child))
656 mime-raw-message-info)
661 (del-alist 'body-presentation-method
662 (copy-alist situation))))
664 (setq children (cdr children)
665 situations (cdr situations)
670 ;;; @ acting-condition
673 (defvar mime-acting-condition nil
674 "Condition-tree about how to process entity.")
676 (if (file-readable-p mailcap-file)
677 (let ((entries (mailcap-parse-file)))
679 (let ((entry (car entries))
682 (let* ((field (car entry))
683 (field-type (car field)))
684 (cond ((eq field-type 'view) (setq view field))
685 ((eq field-type 'print) (setq print field))
686 ((memq field-type '(compose composetyped edit)))
687 (t (setq shared (cons field shared))))
689 (setq entry (cdr entry))
691 (setq shared (nreverse shared))
692 (ctree-set-calist-with-default
693 'mime-acting-condition
694 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
696 (ctree-set-calist-with-default
697 'mime-acting-condition
699 (list '(mode . "print")(cons 'method (cdr view))))
702 (setq entries (cdr entries))
705 (ctree-set-calist-strictly
706 'mime-acting-condition
707 '((type . application)(subtype . octet-stream)
709 (method . mime-method-to-detect)
712 (ctree-set-calist-with-default
713 'mime-acting-condition
715 (method . mime-method-to-save)))
717 (ctree-set-calist-strictly
718 'mime-acting-condition
719 '((type . text)(subtype . x-rot13-47)(mode . "play")
720 (method . mime-method-to-display-caesar)
722 (ctree-set-calist-strictly
723 'mime-acting-condition
724 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
725 (method . mime-method-to-display-caesar)
728 (ctree-set-calist-strictly
729 'mime-acting-condition
730 '((type . message)(subtype . rfc822)(mode . "play")
731 (method . mime-method-to-display-message/rfc822)
733 (ctree-set-calist-strictly
734 'mime-acting-condition
735 '((type . message)(subtype . partial)(mode . "play")
736 (method . mime-method-to-store-message/partial)
739 (ctree-set-calist-strictly
740 'mime-acting-condition
741 '((type . message)(subtype . external-body)
742 ("access-type" . "anon-ftp")
743 (method . mime-method-to-display-message/external-ftp)
746 (ctree-set-calist-strictly
747 'mime-acting-condition
748 '((type . application)(subtype . octet-stream)
749 (method . mime-method-to-save)
753 ;;; @ quitting method
756 (defvar mime-preview-quitting-method-alist
757 '((mime-show-message-mode
758 . mime-preview-quitting-method-for-mime-show-message-mode))
759 "Alist of major-mode vs. quitting-method of mime-view.")
761 (defvar mime-preview-over-to-previous-method-alist nil
762 "Alist of major-mode vs. over-to-previous-method of mime-view.")
764 (defvar mime-preview-over-to-next-method-alist nil
765 "Alist of major-mode vs. over-to-next-method of mime-view.")
768 ;;; @ following method
771 (defvar mime-view-following-method-alist nil
772 "Alist of major-mode vs. following-method of mime-view.")
774 (defvar mime-view-following-required-fields-list
781 ;; hack from Gnus 5.0.4.
783 (defvar mime-view-x-face-to-pbm-command
784 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
786 (defvar mime-view-x-face-command
787 (concat mime-view-x-face-to-pbm-command
789 "String to be executed to display an X-Face field.
790 The command will be executed in a sub-shell asynchronously.
791 The compressed face will be piped to this command.")
793 (defun mime-view-x-face-function ()
794 "Function to display X-Face field. You can redefine to customize."
795 ;; 1995/10/12 (c.f. tm-eng:130)
796 ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
798 (narrow-to-region (point-min) (re-search-forward "^$" nil t))
800 (goto-char (point-min))
801 (if (re-search-forward "^X-Face:[ \t]*" nil t)
802 (let ((beg (match-end 0))
803 (end (std11-field-end))
805 (call-process-region beg end "sh" nil 0 nil
806 "-c" mime-view-x-face-command)
813 (defun mime-view-display-entity (entity message-info obuf
816 (let* ((raw-buffer (mime-entity-buffer entity))
817 (start (mime-entity-point-min entity))
818 (end (mime-entity-point-max entity))
819 original-major-mode end-of-header e nb ne subj)
820 (set-buffer raw-buffer)
821 (setq original-major-mode major-mode)
823 (setq end-of-header (if (re-search-forward "^$" nil t)
826 (if (> end-of-header end)
827 (setq end-of-header end)
830 (narrow-to-region start end)
831 (setq subj (eword-decode-string (mime-raw-get-subject entity)))
835 (or (ctree-match-calist mime-preview-condition
836 (append (mime-entity-situation entity)
839 (let ((button-is-invisible
840 (eq (cdr (assq 'entity-button situation)) 'invisible))
842 (eq (cdr (assq 'header situation)) 'visible))
843 (body-presentation-method
844 (cdr (assq 'body-presentation-method situation)))
845 (children (mime-entity-children entity)))
848 (narrow-to-region nb nb)
849 (or button-is-invisible
850 (if (mime-view-entity-button-visible-p entity)
851 (mime-view-insert-entity-button entity subj)
853 (if header-is-visible
855 (narrow-to-region (point)(point))
856 (insert-buffer-substring raw-buffer start end-of-header)
857 (let ((f (cdr (assq original-major-mode
858 mime-view-content-header-filter-alist))))
861 (mime-view-default-content-header-filter)
863 (run-hooks 'mime-view-content-header-filter-hook)
865 (cond ((eq body-presentation-method 'with-filter)
866 (let ((body-filter (cdr (assq 'body-filter situation))))
868 (narrow-to-region (point-max)(point-max))
869 (insert-buffer-substring raw-buffer end-of-header end)
870 (funcall body-filter situation)
873 ((functionp body-presentation-method)
874 (funcall body-presentation-method entity situation)
877 (when button-is-invisible
878 (goto-char (point-max))
879 (mime-view-insert-entity-button entity subj)
881 (or header-is-visible
883 (goto-char (point-max))
887 (setq ne (point-max))
889 (put-text-property nb ne 'mime-view-entity entity)
892 (if (functionp body-presentation-method)
893 (funcall body-presentation-method entity situation)
894 (mime-preview-multipart/mixed entity situation)
899 ;;; @ MIME viewer mode
902 (defconst mime-view-menu-title "MIME-View")
903 (defconst mime-view-menu-list
904 '((up "Move to upper entity" mime-preview-move-to-upper)
905 (previous "Move to previous entity" mime-preview-move-to-previous)
906 (next "Move to next entity" mime-preview-move-to-next)
907 (scroll-down "Scroll-down" mime-preview-scroll-down-entity)
908 (scroll-up "Scroll-up" mime-preview-scroll-up-entity)
909 (play "Play current entity" mime-preview-play-current-entity)
910 (extract "Extract current entity" mime-preview-extract-current-entity)
911 (print "Print current entity" mime-preview-print-current-entity)
912 (x-face "Show X Face" mime-preview-display-x-face)
914 "Menu for MIME Viewer")
916 (cond (running-xemacs
917 (defvar mime-view-xemacs-popup-menu
918 (cons mime-view-menu-title
921 (vector (nth 1 item)(nth 2 item) t)
923 mime-view-menu-list)))
924 (defun mime-view-xemacs-popup-menu (event)
925 "Popup the menu in the MIME Viewer buffer"
927 (select-window (event-window event))
928 (set-buffer (event-buffer event))
929 (popup-menu 'mime-view-xemacs-popup-menu))
930 (defvar mouse-button-2 'button2)
933 (defvar mouse-button-2 [mouse-2])
936 (defun mime-view-define-keymap (&optional default)
937 (let ((mime-view-mode-map (if (keymapp default)
938 (copy-keymap default)
941 (define-key mime-view-mode-map
942 "u" (function mime-preview-move-to-upper))
943 (define-key mime-view-mode-map
944 "p" (function mime-preview-move-to-previous))
945 (define-key mime-view-mode-map
946 "n" (function mime-preview-move-to-next))
947 (define-key mime-view-mode-map
948 "\e\t" (function mime-preview-move-to-previous))
949 (define-key mime-view-mode-map
950 "\t" (function mime-preview-move-to-next))
951 (define-key mime-view-mode-map
952 " " (function mime-preview-scroll-up-entity))
953 (define-key mime-view-mode-map
954 "\M- " (function mime-preview-scroll-down-entity))
955 (define-key mime-view-mode-map
956 "\177" (function mime-preview-scroll-down-entity))
957 (define-key mime-view-mode-map
958 "\C-m" (function mime-preview-next-line-entity))
959 (define-key mime-view-mode-map
960 "\C-\M-m" (function mime-preview-previous-line-entity))
961 (define-key mime-view-mode-map
962 "v" (function mime-preview-play-current-entity))
963 (define-key mime-view-mode-map
964 "e" (function mime-preview-extract-current-entity))
965 (define-key mime-view-mode-map
966 "\C-c\C-p" (function mime-preview-print-current-entity))
967 (define-key mime-view-mode-map
968 "a" (function mime-preview-follow-current-entity))
969 (define-key mime-view-mode-map
970 "q" (function mime-preview-quit))
971 (define-key mime-view-mode-map
972 "\C-c\C-x" (function mime-preview-kill-buffer))
973 ;; (define-key mime-view-mode-map
974 ;; "<" (function beginning-of-buffer))
975 ;; (define-key mime-view-mode-map
976 ;; ">" (function end-of-buffer))
977 (define-key mime-view-mode-map
978 "?" (function describe-mode))
979 (define-key mime-view-mode-map
980 [tab] (function mime-preview-move-to-next))
981 (define-key mime-view-mode-map
982 [delete] (function mime-preview-scroll-down-entity))
983 (define-key mime-view-mode-map
984 [backspace] (function mime-preview-scroll-down-entity))
985 (if (functionp default)
986 (cond (running-xemacs
987 (set-keymap-default-binding mime-view-mode-map default)
990 (setq mime-view-mode-map
991 (append mime-view-mode-map (list (cons t default))))
994 (define-key mime-view-mode-map
995 mouse-button-2 (function mime-button-dispatcher))
997 (cond (running-xemacs
998 (define-key mime-view-mode-map
999 mouse-button-3 (function mime-view-xemacs-popup-menu))
1001 ((>= emacs-major-version 19)
1002 (define-key mime-view-mode-map [menu-bar mime-view]
1003 (cons mime-view-menu-title
1004 (make-sparse-keymap mime-view-menu-title)))
1007 (define-key mime-view-mode-map
1008 (vector 'menu-bar 'mime-view (car item))
1009 (cons (nth 1 item)(nth 2 item))
1012 (reverse mime-view-menu-list)
1015 (use-local-map mime-view-mode-map)
1016 (run-hooks 'mime-view-define-keymap-hook)
1019 (defsubst mime-maybe-hide-echo-buffer ()
1020 "Clear mime-echo buffer and delete window for it."
1021 (let ((buf (get-buffer mime-echo-buffer-name)))
1026 (let ((win (get-buffer-window buf)))
1033 (defvar mime-view-redisplay nil)
1035 (defun mime-view-display-message (message &optional preview-buffer
1036 mother default-keymap-or-function)
1037 (mime-maybe-hide-echo-buffer)
1038 (let ((win-conf (current-window-configuration))
1039 (raw-buffer (mime-entity-buffer message)))
1041 (setq preview-buffer
1042 (concat "*Preview-" (buffer-name raw-buffer) "*")))
1043 (set-buffer raw-buffer)
1044 (setq mime-raw-message-info (mime-parse-message))
1045 (setq mime-preview-buffer preview-buffer)
1046 (let ((inhibit-read-only t))
1047 (switch-to-buffer preview-buffer)
1050 (setq mime-raw-buffer raw-buffer)
1052 (setq mime-mother-buffer mother)
1054 (setq mime-preview-original-window-configuration win-conf)
1055 (setq major-mode 'mime-view-mode)
1056 (setq mode-name "MIME-View")
1057 (mime-view-display-entity message message
1059 '((entity-button . invisible)
1062 (mime-view-define-keymap default-keymap-or-function)
1064 (next-single-property-change (point-min) 'mime-view-entity)))
1067 (goto-char (point-min))
1068 (search-forward "\n\n" nil t)
1070 (run-hooks 'mime-view-mode-hook)
1072 (set-buffer-modified-p nil)
1073 (setq buffer-read-only t)
1076 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1077 default-keymap-or-function)
1079 (mime-view-display-message
1081 (if raw-buffer (set-buffer raw-buffer))
1082 (mime-parse-message)
1084 preview-buffer mother default-keymap-or-function))
1086 (defun mime-view-mode (&optional mother ctl encoding
1087 raw-buffer preview-buffer
1088 default-keymap-or-function)
1089 "Major mode for viewing MIME message.
1091 Here is a list of the standard keys for mime-view-mode.
1096 u Move to upper content
1097 p or M-TAB Move to previous content
1098 n or TAB Move to next content
1099 SPC Scroll up or move to next content
1100 M-SPC or DEL Scroll down or move to previous content
1101 RET Move to next line
1102 M-RET Move to previous line
1103 v Decode current content as `play mode'
1104 e Decode current content as `extract mode'
1105 C-c C-p Decode current content as `print mode'
1106 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-view-display-message
1114 (if raw-buffer (set-buffer raw-buffer))
1115 (or mime-view-redisplay
1116 (mime-parse-message ctl encoding))
1118 preview-buffer mother default-keymap-or-function))
1124 (autoload 'mime-preview-play-current-entity "mime-play"
1125 "Play current entity." t)
1127 (defun mime-preview-extract-current-entity ()
1128 "Extract current entity into file (maybe).
1129 It decodes current entity to call internal or external method as
1130 \"extract\" mode. The method is selected from variable
1131 `mime-acting-condition'."
1133 (mime-preview-play-current-entity "extract")
1136 (defun mime-preview-print-current-entity ()
1137 "Print current entity (maybe).
1138 It decodes current entity to call internal or external method as
1139 \"print\" mode. The method is selected from variable
1140 `mime-acting-condition'."
1142 (mime-preview-play-current-entity "print")
1149 (defun mime-preview-follow-current-entity ()
1150 "Write follow message to current entity.
1151 It calls following-method selected from variable
1152 `mime-view-following-method-alist'."
1155 (while (null (setq entity
1156 (get-text-property (point) 'mime-view-entity)))
1160 (previous-single-property-change (point) 'mime-view-entity))
1162 (entity-node-id (mime-entity-node-id entity))
1163 (len (length entity-node-id))
1167 (if (eq (next-single-property-change (point-min)
1173 ((eq (next-single-property-change p-beg 'mime-view-entity)
1175 (setq p-beg (point))
1177 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1179 (setq p-end (point-max))
1181 ((null entity-node-id)
1182 (setq p-end (point-max))
1190 (next-single-property-change
1191 (point) 'mime-view-entity))
1193 (let ((rc (mime-entity-node-id
1194 (get-text-property (point)
1195 'mime-view-entity))))
1196 (or (equal entity-node-id
1197 (nthcdr (- (length rc) len) rc))
1202 (setq p-end (point-max))
1205 (let* ((mode (mime-preview-original-major-mode 'recursive))
1207 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1209 (the-buf (current-buffer))
1210 (a-buf mime-raw-buffer)
1213 (set-buffer (setq new-buf (get-buffer-create new-name)))
1215 (insert-buffer-substring the-buf p-beg p-end)
1216 (goto-char (point-min))
1217 (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1225 (mime-raw-find-entity-from-node-id entity-node-id))
1228 (mime-entity-point-min ci)
1229 (mime-entity-point-max ci)
1231 (std11-header-string-except
1233 (apply (function regexp-or) fields)
1236 (eq (mime-entity-media-type ci) 'message)
1237 (eq (mime-entity-media-subtype ci) 'rfc822))
1243 (setq fields (std11-collect-field-names)
1244 entity-node-id (cdr entity-node-id))
1247 (let ((rest mime-view-following-required-fields-list))
1249 (let ((field-name (car rest)))
1250 (or (std11-field-body field-name)
1256 (set-buffer the-buf)
1257 (set-buffer mime-mother-buffer)
1258 (set-buffer mime-raw-buffer)
1259 (std11-field-body field-name)
1263 (setq rest (cdr rest))
1265 (eword-decode-header)
1267 (let ((f (cdr (assq mode mime-view-following-method-alist))))
1272 "Sorry, following method for %s is not implemented yet."
1281 (defun mime-preview-display-x-face ()
1283 (save-window-excursion
1284 (set-buffer mime-raw-buffer)
1285 (mime-view-x-face-function)
1292 (defun mime-preview-move-to-upper ()
1293 "Move to upper entity.
1294 If there is no upper entity, call function `mime-preview-quit'."
1297 (while (null (setq cinfo
1298 (get-text-property (point) 'mime-view-entity)))
1301 (let ((r (mime-raw-find-entity-from-node-id
1302 (cdr (mime-entity-node-id cinfo))
1303 (get-text-property 1 'mime-view-entity)))
1306 (while (setq point (previous-single-property-change
1307 (point) 'mime-view-entity))
1309 (if (eq r (get-text-property (point) 'mime-view-entity))
1316 (defun mime-preview-move-to-previous ()
1317 "Move to previous entity.
1318 If there is no previous entity, it calls function registered in
1319 variable `mime-preview-over-to-previous-method-alist'."
1321 (while (null (get-text-property (point) 'mime-view-entity))
1324 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1326 (if (get-text-property (1- point) 'mime-view-entity)
1328 (goto-char (1- point))
1329 (mime-preview-move-to-previous)
1331 (let ((f (assq (mime-preview-original-major-mode)
1332 mime-preview-over-to-previous-method-alist)))
1338 (defun mime-preview-move-to-next ()
1339 "Move to next entity.
1340 If there is no previous entity, it calls function registered in
1341 variable `mime-preview-over-to-next-method-alist'."
1343 (while (null (get-text-property (point) 'mime-view-entity))
1346 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1350 (if (null (get-text-property point 'mime-view-entity))
1351 (mime-preview-move-to-next)
1353 (let ((f (assq (mime-preview-original-major-mode)
1354 mime-preview-over-to-next-method-alist)))
1360 (defun mime-preview-scroll-up-entity (&optional h)
1361 "Scroll up current entity.
1362 If reached to (point-max), it calls function registered in variable
1363 `mime-preview-over-to-next-method-alist'."
1366 (setq h (1- (window-height)))
1368 (if (= (point) (point-max))
1369 (let ((f (assq (mime-preview-original-major-mode)
1370 mime-preview-over-to-next-method-alist)))
1375 (or (next-single-property-change (point) 'mime-view-entity)
1378 (if (> (point) point)
1383 (defun mime-preview-scroll-down-entity (&optional h)
1384 "Scroll down current entity.
1385 If reached to (point-min), it calls function registered in variable
1386 `mime-preview-over-to-previous-method-alist'."
1389 (setq h (1- (window-height)))
1391 (if (= (point) (point-min))
1392 (let ((f (assq (mime-preview-original-major-mode)
1393 mime-preview-over-to-previous-method-alist)))
1398 (or (previous-single-property-change (point) 'mime-view-entity)
1400 (forward-line (- h))
1401 (if (< (point) point)
1405 (defun mime-preview-next-line-entity ()
1407 (mime-preview-scroll-up-entity 1)
1410 (defun mime-preview-previous-line-entity ()
1412 (mime-preview-scroll-down-entity 1)
1419 (defun mime-preview-quit ()
1420 "Quit from MIME-preview buffer.
1421 It calls function registered in variable
1422 `mime-preview-quitting-method-alist'."
1424 (let ((r (assq (mime-preview-original-major-mode)
1425 mime-preview-quitting-method-alist)))
1430 (defun mime-preview-kill-buffer ()
1432 (kill-buffer (current-buffer))
1439 (provide 'mime-view)
1441 (run-hooks 'mime-view-load-hook)
1443 ;;; mime-view.el ends here