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.
41 (defconst mime-view-version-string
42 `,(concat (car mime-user-interface-version) " MIME-View "
43 (mapconcat #'number-to-string
44 (cddr mime-user-interface-version) ".")
45 " (" (cadr mime-user-interface-version) ")"))
51 (defgroup mime-view nil
55 (defcustom mime-view-find-every-acting-situation t
56 "*Find every available acting-situation if non-nil."
60 (defcustom mime-acting-situation-examples-file "~/.mime-example"
61 "*File name of example about acting-situation demonstrated by user."
66 ;;; @ in raw-buffer (representation space)
69 (defvar mime-preview-buffer nil
70 "MIME-preview buffer corresponding with the (raw) buffer.")
71 (make-variable-buffer-local 'mime-preview-buffer)
74 (defvar mime-raw-representation-type nil
75 "Representation-type of mime-raw-buffer.
76 It must be nil, `binary' or `cooked'.
77 If it is nil, `mime-raw-representation-type-alist' is used as default
79 Notice that this variable is usually used as buffer local variable in
82 (make-variable-buffer-local 'mime-raw-representation-type)
84 (defvar mime-raw-representation-type-alist
85 '((mime-show-message-mode . binary)
86 (mime-temp-message-mode . binary)
89 "Alist of major-mode vs. representation-type of mime-raw-buffer.
90 Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
91 major-mode or t. t means default. REPRESENTATION-TYPE must be
93 This value is overridden by buffer local variable
94 `mime-raw-representation-type' if it is not nil.")
97 (defsubst mime-raw-find-entity-from-node-id (entity-node-id
98 &optional message-info)
99 "Return entity from ENTITY-NODE-ID in mime-raw-buffer.
100 If optional argument MESSAGE-INFO is not specified,
101 `mime-message-structure' is used."
102 (mime-raw-find-entity-from-number (reverse entity-node-id) message-info))
104 (defun mime-raw-find-entity-from-number (entity-number &optional message-info)
105 "Return entity from ENTITY-NUMBER in mime-raw-buffer.
106 If optional argument MESSAGE-INFO is not specified,
107 `mime-message-structure' is used."
109 (setq message-info mime-message-structure))
110 (if (eq entity-number t)
112 (let ((sn (car entity-number)))
115 (let ((rc (nth sn (mime-entity-children message-info))))
117 (mime-raw-find-entity-from-number (cdr entity-number) rc)
121 (defun mime-raw-find-entity-from-point (point &optional message-info)
122 "Return entity from POINT in mime-raw-buffer.
123 If optional argument MESSAGE-INFO is not specified,
124 `mime-message-structure' is used."
126 (setq message-info mime-message-structure))
127 (if (and (<= (mime-entity-point-min message-info) point)
128 (<= point (mime-entity-point-max message-info)))
129 (let ((children (mime-entity-children message-info)))
133 (mime-raw-find-entity-from-point point (car children))))
137 (setq children (cdr children)))
141 ;;; @ in preview-buffer (presentation space)
144 (defvar mime-mother-buffer nil
145 "Mother buffer corresponding with the (MIME-preview) buffer.
146 If current MIME-preview buffer is generated by other buffer, such as
147 message/partial, it is called `mother-buffer'.")
148 (make-variable-buffer-local 'mime-mother-buffer)
150 (defvar mime-raw-buffer nil
151 "Raw buffer corresponding with the (MIME-preview) buffer.")
152 (make-variable-buffer-local 'mime-raw-buffer)
154 (defvar mime-preview-original-window-configuration nil
155 "Window-configuration before mime-view-mode is called.")
156 (make-variable-buffer-local 'mime-preview-original-window-configuration)
158 (defun mime-preview-original-major-mode (&optional recursive)
159 "Return major-mode of original buffer.
160 If optional argument RECURSIVE is non-nil and current buffer has
161 mime-mother-buffer, it returns original major-mode of the
163 (if (and recursive mime-mother-buffer)
165 (set-buffer mime-mother-buffer)
166 (mime-preview-original-major-mode recursive)
171 (get-text-property (point-min) 'mime-view-entity)))
175 ;;; @ entity information
178 (defsubst mime-entity-parent (entity &optional message-info)
179 "Return mother entity of ENTITY.
180 If optional argument MESSAGE-INFO is not specified,
181 `mime-message-structure' in buffer of ENTITY is used."
182 (mime-raw-find-entity-from-node-id
183 (cdr (mime-entity-node-id entity))
186 (set-buffer (mime-entity-buffer entity))
187 mime-message-structure))))
189 (defun mime-entity-situation (entity)
190 "Return situation of ENTITY."
191 (append (or (mime-entity-content-type entity)
192 (make-mime-content-type 'text 'plain))
193 (let ((d (mime-entity-content-disposition entity)))
194 (cons (cons 'disposition-type
195 (mime-content-disposition-type d))
198 (let ((name (car param)))
199 (cons (cond ((string= name "filename")
201 ((string= name "creation-date")
203 ((string= name "modification-date")
205 ((string= name "read-date")
207 ((string= name "size")
209 (t (cons 'disposition (car param))))
211 (mime-content-disposition-parameters d))
213 (list (cons 'encoding (mime-entity-encoding entity))
216 (set-buffer (mime-entity-buffer entity))
221 (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode"))
223 (defun mime-entity-uu-filename (entity)
224 (if (member (mime-entity-encoding entity)
225 mime-view-uuencode-encoding-name-list)
227 (set-buffer (mime-entity-buffer entity))
228 (goto-char (mime-entity-body-start entity))
229 (if (re-search-forward "^begin [0-9]+ "
230 (mime-entity-body-end entity) t)
231 (if (looking-at ".+$")
232 (buffer-substring (match-beginning 0)(match-end 0))
235 (defun mime-entity-filename (entity)
236 (or (mime-entity-uu-filename entity)
237 (let ((ret (mime-entity-content-disposition entity)))
239 (setq ret (mime-content-disposition-filename ret))
240 (std11-strip-quoted-string ret)
242 (let ((ret (mime-entity-content-type entity)))
246 (let ((param (mime-content-type-parameters ret)))
247 (or (assoc "name" param)
248 (assoc "x-name" param))
250 (std11-strip-quoted-string ret)
254 (defun mime-view-entity-title (entity)
255 (or (mime-entity-read-field entity 'Content-Description)
256 (mime-entity-read-field entity 'Subject)
257 (mime-entity-filename entity)
261 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
262 "Return entity-node-id from POINT in mime-raw-buffer.
263 If optional argument MESSAGE-INFO is not specified,
264 `mime-message-structure' is used."
265 (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
267 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
268 "Return entity-number from POINT in mime-raw-buffer.
269 If optional argument MESSAGE-INFO is not specified,
270 `mime-message-structure' is used."
271 (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
273 (defun mime-raw-flatten-message-info (&optional message-info)
274 "Return list of entity in mime-raw-buffer.
275 If optional argument MESSAGE-INFO is not specified,
276 `mime-message-structure' is used."
278 (setq message-info mime-message-structure))
279 (let ((dest (list message-info))
280 (rcl (mime-entity-children message-info)))
282 (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
283 (setq rcl (cdr rcl)))
287 ;;; @ presentation of preview
293 ;;; @@@ predicate function
296 (defun mime-view-entity-button-visible-p (entity)
297 "Return non-nil if header of ENTITY is visible.
298 Please redefine this function if you want to change default setting."
299 (let ((media-type (mime-entity-media-type entity))
300 (media-subtype (mime-entity-media-subtype entity)))
301 (or (not (eq media-type 'application))
302 (and (not (eq media-subtype 'x-selection))
303 (or (not (eq media-subtype 'octet-stream))
304 (let ((mother-entity (mime-entity-parent entity)))
305 (or (not (eq (mime-entity-media-type mother-entity)
307 (not (eq (mime-entity-media-subtype mother-entity)
312 ;;; @@@ entity button generator
315 (defun mime-view-insert-entity-button (entity)
316 "Insert entity-button of ENTITY."
317 (let ((entity-node-id (mime-entity-node-id entity))
318 (params (mime-entity-parameters entity))
319 (subject (mime-view-entity-title entity)))
321 (let ((access-type (assoc "access-type" params))
322 (num (or (cdr (assoc "x-part-number" params))
323 (if (consp entity-node-id)
326 (format "%s" (1+ num))
328 (reverse entity-node-id) ".")
332 (let ((server (assoc "server" params)))
333 (setq access-type (cdr access-type))
335 (format "%s %s ([%s] %s)"
336 num subject access-type (cdr server))
337 (let ((site (cdr (assoc "site" params)))
338 (dir (cdr (assoc "directory" params)))
340 (format "%s %s ([%s] %s:%s)"
341 num subject access-type site dir)
345 (let ((media-type (mime-entity-media-type entity))
346 (media-subtype (mime-entity-media-subtype entity))
347 (charset (cdr (assoc "charset" params)))
348 (encoding (mime-entity-encoding entity)))
352 (format " <%s/%s%s%s>"
353 media-type media-subtype
355 (concat "; " charset)
358 (concat " (" encoding ")")
360 (if (>= (+ (current-column)(length rest))(window-width))
364 (function mime-preview-play-current-entity))
371 (defvar mime-header-presentation-method-alist nil
372 "Alist of major mode vs. corresponding header-presentation-method functions.
373 Each element looks like (SYMBOL . FUNCTION).
374 SYMBOL must be major mode in raw-buffer or t. t means default.
375 Interface of FUNCTION must be (ENTITY SITUATION).")
377 (defvar mime-view-ignored-field-list
378 '(".*Received" ".*Path" ".*Id" "References"
379 "Replied" "Errors-To"
380 "Lines" "Sender" ".*Host" "Xref"
381 "Content-Type" "Precedence"
383 "All fields that match this list will be hidden in MIME preview buffer.
384 Each elements are regexp of field-name.")
386 (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id")
387 "All fields that match this list will be displayed in MIME preview buffer.
388 Each elements are regexp of field-name.")
394 ;;; @@@ predicate function
397 (defun mime-calist::field-match-method-as-default-rule (calist
398 field-type field-value)
399 (let ((s-field (assq field-type calist)))
400 (cond ((null s-field)
401 (cons (cons field-type field-value) calist)
405 (define-calist-field-match-method
406 'header #'mime-calist::field-match-method-as-default-rule)
408 (define-calist-field-match-method
409 'body #'mime-calist::field-match-method-as-default-rule)
412 (defvar mime-preview-condition nil
413 "Condition-tree about how to display entity.")
415 (ctree-set-calist-strictly
416 'mime-preview-condition '((type . application)(subtype . octet-stream)
419 (ctree-set-calist-strictly
420 'mime-preview-condition '((type . application)(subtype . octet-stream)
423 (ctree-set-calist-strictly
424 'mime-preview-condition '((type . application)(subtype . octet-stream)
428 (ctree-set-calist-strictly
429 'mime-preview-condition '((type . application)(subtype . pgp)
432 (ctree-set-calist-strictly
433 'mime-preview-condition '((type . application)(subtype . x-latex)
436 (ctree-set-calist-strictly
437 'mime-preview-condition '((type . application)(subtype . x-selection)
440 (ctree-set-calist-strictly
441 'mime-preview-condition '((type . application)(subtype . x-comment)
444 (ctree-set-calist-strictly
445 'mime-preview-condition '((type . message)(subtype . delivery-status)
448 (ctree-set-calist-strictly
449 'mime-preview-condition
451 (body-presentation-method . mime-display-text/plain)))
453 (ctree-set-calist-strictly
454 'mime-preview-condition
457 (body-presentation-method . mime-display-text/plain)))
459 (ctree-set-calist-strictly
460 'mime-preview-condition
461 '((type . text)(subtype . enriched)
463 (body-presentation-method . mime-display-text/enriched)))
465 (ctree-set-calist-strictly
466 'mime-preview-condition
467 '((type . text)(subtype . richtext)
469 (body-presentation-method . mime-display-text/richtext)))
471 (ctree-set-calist-strictly
472 'mime-preview-condition
473 '((type . text)(subtype . t)
475 (body-presentation-method . mime-display-text/plain)))
477 (ctree-set-calist-strictly
478 'mime-preview-condition
479 '((type . multipart)(subtype . alternative)
481 (body-presentation-method . mime-display-multipart/alternative)))
483 (ctree-set-calist-strictly
484 'mime-preview-condition '((type . message)(subtype . partial)
485 (body-presentation-method
486 . mime-display-message/partial-button)))
488 (ctree-set-calist-strictly
489 'mime-preview-condition '((type . message)(subtype . rfc822)
490 (body-presentation-method . nil)
491 (childrens-situation (header . visible)
492 (entity-button . invisible))))
494 (ctree-set-calist-strictly
495 'mime-preview-condition '((type . message)(subtype . news)
496 (body-presentation-method . nil)
497 (childrens-situation (header . visible)
498 (entity-button . invisible))))
501 ;;; @@@ entity presentation
504 (autoload 'mime-display-text/plain "mime-text")
505 (autoload 'mime-display-text/enriched "mime-text")
506 (autoload 'mime-display-text/richtext "mime-text")
508 (defvar mime-view-announcement-for-message/partial
509 (if (and (>= emacs-major-version 19) window-system)
511 \[[ This is message/partial style split message. ]]
512 \[[ Please press `v' key in this buffer ]]
513 \[[ or click here by mouse button-2. ]]"
515 \[[ This is message/partial style split message. ]]
516 \[[ Please press `v' key in this buffer. ]]"
519 (defun mime-display-message/partial-button (&optional entity situation)
521 (goto-char (point-max))
522 (if (not (search-backward "\n\n" nil t))
525 (goto-char (point-max))
526 (narrow-to-region (point-max)(point-max))
527 (insert mime-view-announcement-for-message/partial)
528 (mime-add-button (point-min)(point-max)
529 #'mime-preview-play-current-entity)
532 (defun mime-display-multipart/mixed (entity situation)
533 (let ((children (mime-entity-children entity))
535 (cdr (assq 'childrens-situation situation))))
537 (mime-display-entity (car children) nil default-situation)
538 (setq children (cdr children))
541 (defcustom mime-view-type-subtype-score-alist
542 '(((text . enriched) . 3)
543 ((text . richtext) . 2)
546 "Alist MEDIA-TYPE vs corresponding score.
547 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
549 :type '(repeat (cons (choice :tag "Media-Type"
550 (item :tag "Type/Subtype"
551 (cons symbol symbol))
552 (item :tag "Type" symbol)
553 (item :tag "Default" t))
556 (defun mime-display-multipart/alternative (entity situation)
557 (let* ((children (mime-entity-children entity))
559 (cdr (assq 'childrens-situation situation)))
567 (or (ctree-match-calist
568 mime-preview-condition
569 (append (mime-entity-situation child)
572 (if (cdr (assq 'body-presentation-method situation))
577 (cdr (assq 'type situation))
578 (cdr (assq 'subtype situation)))
579 mime-view-type-subtype-score-alist)
581 (cdr (assq 'type situation))
582 mime-view-type-subtype-score-alist)
585 mime-view-type-subtype-score-alist)
587 (if (> score max-score)
597 (let ((child (car children))
598 (situation (car situations)))
599 (mime-display-entity child (if (= i p)
601 (del-alist 'body-presentation-method
602 (copy-alist situation))))
604 (setq children (cdr children)
605 situations (cdr situations)
610 ;;; @ acting-condition
613 (defvar mime-acting-condition nil
614 "Condition-tree about how to process entity.")
616 (if (file-readable-p mailcap-file)
617 (let ((entries (mailcap-parse-file)))
619 (let ((entry (car entries))
622 (let* ((field (car entry))
623 (field-type (car field)))
624 (cond ((eq field-type 'view) (setq view field))
625 ((eq field-type 'print) (setq print field))
626 ((memq field-type '(compose composetyped edit)))
627 (t (setq shared (cons field shared))))
629 (setq entry (cdr entry))
631 (setq shared (nreverse shared))
632 (ctree-set-calist-with-default
633 'mime-acting-condition
634 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
636 (ctree-set-calist-with-default
637 'mime-acting-condition
639 (list '(mode . "print")(cons 'method (cdr view))))
642 (setq entries (cdr entries))
645 (ctree-set-calist-strictly
646 'mime-acting-condition
647 '((type . application)(subtype . octet-stream)
649 (method . mime-detect-content)
652 (ctree-set-calist-with-default
653 'mime-acting-condition
655 (method . mime-save-content)))
657 (ctree-set-calist-strictly
658 'mime-acting-condition
659 '((type . text)(subtype . x-rot13-47)(mode . "play")
660 (method . mime-view-caesar)
662 (ctree-set-calist-strictly
663 'mime-acting-condition
664 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
665 (method . mime-view-caesar)
668 (ctree-set-calist-strictly
669 'mime-acting-condition
670 '((type . message)(subtype . rfc822)(mode . "play")
671 (method . mime-view-message/rfc822)
673 (ctree-set-calist-strictly
674 'mime-acting-condition
675 '((type . message)(subtype . partial)(mode . "play")
676 (method . mime-store-message/partial-piece)
679 (ctree-set-calist-strictly
680 'mime-acting-condition
681 '((type . message)(subtype . external-body)
682 ("access-type" . "anon-ftp")
683 (method . mime-view-message/external-ftp)
686 (ctree-set-calist-strictly
687 'mime-acting-condition
688 '((type . application)(subtype . octet-stream)
689 (method . mime-save-content)
693 ;;; @ quitting method
696 (defvar mime-preview-quitting-method-alist
697 '((mime-show-message-mode
698 . mime-preview-quitting-method-for-mime-show-message-mode))
699 "Alist of major-mode vs. quitting-method of mime-view.")
701 (defvar mime-preview-over-to-previous-method-alist nil
702 "Alist of major-mode vs. over-to-previous-method of mime-view.")
704 (defvar mime-preview-over-to-next-method-alist nil
705 "Alist of major-mode vs. over-to-next-method of mime-view.")
708 ;;; @ following method
711 (defvar mime-preview-following-method-alist nil
712 "Alist of major-mode vs. following-method of mime-view.")
714 (defvar mime-view-following-required-fields-list
721 ;; hack from Gnus 5.0.4.
723 (defvar mime-view-x-face-to-pbm-command
724 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
726 (defvar mime-view-x-face-command
727 (concat mime-view-x-face-to-pbm-command
729 "String to be executed to display an X-Face field.
730 The command will be executed in a sub-shell asynchronously.
731 The compressed face will be piped to this command.")
733 (defun mime-view-x-face-function ()
734 "Function to display X-Face field. You can redefine to customize."
735 ;; 1995/10/12 (c.f. tm-eng:130)
736 ;; fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
738 (narrow-to-region (point-min) (re-search-forward "^$" nil t))
740 (goto-char (point-min))
741 (if (re-search-forward "^X-Face:[ \t]*" nil t)
742 (let ((beg (match-end 0))
743 (end (std11-field-end))
745 (call-process-region beg end "sh" nil 0 nil
746 "-c" mime-view-x-face-command)
753 (defun mime-display-entity (entity &optional situation
754 default-situation preview-buffer)
756 (setq preview-buffer (current-buffer)))
757 (let* ((raw-buffer (mime-entity-buffer entity))
758 (start (mime-entity-point-min entity))
760 (set-buffer raw-buffer)
764 (or (ctree-match-calist mime-preview-condition
765 (append (mime-entity-situation entity)
768 (let ((button-is-invisible
769 (eq (cdr (assq 'entity-button situation)) 'invisible))
771 (eq (cdr (assq 'header situation)) 'visible))
772 (header-presentation-method
773 (or (cdr (assq 'header-presentation-method situation))
774 (cdr (assq major-mode mime-header-presentation-method-alist))))
775 (body-presentation-method
776 (cdr (assq 'body-presentation-method situation)))
777 (children (mime-entity-children entity)))
778 (set-buffer preview-buffer)
780 (narrow-to-region nb nb)
781 (or button-is-invisible
782 (if (mime-view-entity-button-visible-p entity)
783 (mime-view-insert-entity-button entity)
785 (when header-is-visible
786 (if header-presentation-method
787 (funcall header-presentation-method entity situation)
788 (mime-insert-decoded-header
790 mime-view-ignored-field-list mime-view-visible-field-list
792 (set-buffer raw-buffer)
793 (if (eq (cdr (assq major-mode mime-raw-representation-type-alist))
795 default-mime-charset)
797 (goto-char (point-max))
799 (run-hooks 'mime-display-header-hook)
802 ((functionp body-presentation-method)
803 (funcall body-presentation-method entity situation)
806 (when button-is-invisible
807 (goto-char (point-max))
808 (mime-view-insert-entity-button entity)
810 (or header-is-visible
812 (goto-char (point-max))
816 (setq ne (point-max))
818 (put-text-property nb ne 'mime-view-entity entity)
821 (if (functionp body-presentation-method)
822 (funcall body-presentation-method entity situation)
823 (mime-display-multipart/mixed entity situation)
828 ;;; @ MIME viewer mode
831 (defconst mime-view-menu-title "MIME-View")
832 (defconst mime-view-menu-list
833 '((up "Move to upper entity" mime-preview-move-to-upper)
834 (previous "Move to previous entity" mime-preview-move-to-previous)
835 (next "Move to next entity" mime-preview-move-to-next)
836 (scroll-down "Scroll-down" mime-preview-scroll-down-entity)
837 (scroll-up "Scroll-up" mime-preview-scroll-up-entity)
838 (play "Play current entity" mime-preview-play-current-entity)
839 (extract "Extract current entity" mime-preview-extract-current-entity)
840 (print "Print current entity" mime-preview-print-current-entity)
841 (x-face "Show X Face" mime-preview-display-x-face)
843 "Menu for MIME Viewer")
845 (cond (running-xemacs
846 (defvar mime-view-xemacs-popup-menu
847 (cons mime-view-menu-title
850 (vector (nth 1 item)(nth 2 item) t)
852 mime-view-menu-list)))
853 (defun mime-view-xemacs-popup-menu (event)
854 "Popup the menu in the MIME Viewer buffer"
856 (select-window (event-window event))
857 (set-buffer (event-buffer event))
858 (popup-menu 'mime-view-xemacs-popup-menu))
859 (defvar mouse-button-2 'button2)
862 (defvar mouse-button-2 [mouse-2])
865 (defun mime-view-define-keymap (&optional default)
866 (let ((mime-view-mode-map (if (keymapp default)
867 (copy-keymap default)
870 (define-key mime-view-mode-map
871 "u" (function mime-preview-move-to-upper))
872 (define-key mime-view-mode-map
873 "p" (function mime-preview-move-to-previous))
874 (define-key mime-view-mode-map
875 "n" (function mime-preview-move-to-next))
876 (define-key mime-view-mode-map
877 "\e\t" (function mime-preview-move-to-previous))
878 (define-key mime-view-mode-map
879 "\t" (function mime-preview-move-to-next))
880 (define-key mime-view-mode-map
881 " " (function mime-preview-scroll-up-entity))
882 (define-key mime-view-mode-map
883 "\M- " (function mime-preview-scroll-down-entity))
884 (define-key mime-view-mode-map
885 "\177" (function mime-preview-scroll-down-entity))
886 (define-key mime-view-mode-map
887 "\C-m" (function mime-preview-next-line-entity))
888 (define-key mime-view-mode-map
889 "\C-\M-m" (function mime-preview-previous-line-entity))
890 (define-key mime-view-mode-map
891 "v" (function mime-preview-play-current-entity))
892 (define-key mime-view-mode-map
893 "e" (function mime-preview-extract-current-entity))
894 (define-key mime-view-mode-map
895 "\C-c\C-p" (function mime-preview-print-current-entity))
896 (define-key mime-view-mode-map
897 "a" (function mime-preview-follow-current-entity))
898 (define-key mime-view-mode-map
899 "q" (function mime-preview-quit))
900 (define-key mime-view-mode-map
901 "\C-c\C-x" (function mime-preview-kill-buffer))
902 ;; (define-key mime-view-mode-map
903 ;; "<" (function beginning-of-buffer))
904 ;; (define-key mime-view-mode-map
905 ;; ">" (function end-of-buffer))
906 (define-key mime-view-mode-map
907 "?" (function describe-mode))
908 (define-key mime-view-mode-map
909 [tab] (function mime-preview-move-to-next))
910 (define-key mime-view-mode-map
911 [delete] (function mime-preview-scroll-down-entity))
912 (define-key mime-view-mode-map
913 [backspace] (function mime-preview-scroll-down-entity))
914 (if (functionp default)
915 (cond (running-xemacs
916 (set-keymap-default-binding mime-view-mode-map default)
919 (setq mime-view-mode-map
920 (append mime-view-mode-map (list (cons t default))))
923 (define-key mime-view-mode-map
924 mouse-button-2 (function mime-button-dispatcher))
926 (cond (running-xemacs
927 (define-key mime-view-mode-map
928 mouse-button-3 (function mime-view-xemacs-popup-menu))
930 ((>= emacs-major-version 19)
931 (define-key mime-view-mode-map [menu-bar mime-view]
932 (cons mime-view-menu-title
933 (make-sparse-keymap mime-view-menu-title)))
936 (define-key mime-view-mode-map
937 (vector 'menu-bar 'mime-view (car item))
938 (cons (nth 1 item)(nth 2 item))
941 (reverse mime-view-menu-list)
944 (use-local-map mime-view-mode-map)
945 (run-hooks 'mime-view-define-keymap-hook)
948 (defsubst mime-maybe-hide-echo-buffer ()
949 "Clear mime-echo buffer and delete window for it."
950 (let ((buf (get-buffer mime-echo-buffer-name)))
955 (let ((win (get-buffer-window buf)))
962 (defvar mime-view-redisplay nil)
964 (defun mime-display-message (message &optional preview-buffer
965 mother default-keymap-or-function)
966 (mime-maybe-hide-echo-buffer)
967 (let ((win-conf (current-window-configuration))
968 (raw-buffer (mime-entity-buffer message)))
971 (concat "*Preview-" (buffer-name raw-buffer) "*")))
972 (set-buffer raw-buffer)
974 (setq mime-preview-buffer preview-buffer)
975 (let ((inhibit-read-only t))
976 (switch-to-buffer preview-buffer)
979 (setq mime-raw-buffer raw-buffer)
981 (setq mime-mother-buffer mother)
983 (setq mime-preview-original-window-configuration win-conf)
984 (setq major-mode 'mime-view-mode)
985 (setq mode-name "MIME-View")
986 (mime-display-entity message nil
987 '((entity-button . invisible)
990 (mime-view-define-keymap default-keymap-or-function)
992 (next-single-property-change (point-min) 'mime-view-entity)))
995 (goto-char (point-min))
996 (search-forward "\n\n" nil t)
998 (run-hooks 'mime-view-mode-hook)
1000 (set-buffer-modified-p nil)
1001 (setq buffer-read-only t)
1004 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1005 default-keymap-or-function)
1007 (mime-display-message
1009 (if raw-buffer (set-buffer raw-buffer))
1010 (mime-parse-message)
1012 preview-buffer mother default-keymap-or-function))
1014 (defun mime-view-mode (&optional mother ctl encoding
1015 raw-buffer preview-buffer
1016 default-keymap-or-function)
1017 "Major mode for viewing MIME message.
1019 Here is a list of the standard keys for mime-view-mode.
1024 u Move to upper content
1025 p or M-TAB Move to previous content
1026 n or TAB Move to next content
1027 SPC Scroll up or move to next content
1028 M-SPC or DEL Scroll down or move to previous content
1029 RET Move to next line
1030 M-RET Move to previous line
1031 v Decode current content as `play mode'
1032 e Decode current content as `extract mode'
1033 C-c C-p Decode current content as `print mode'
1034 a Followup to current content.
1036 button-2 Move to point under the mouse cursor
1037 and decode current content as `play mode'
1040 (mime-display-message
1042 (if raw-buffer (set-buffer raw-buffer))
1043 (or mime-view-redisplay
1044 (mime-parse-message ctl encoding))
1046 preview-buffer mother default-keymap-or-function))
1052 (autoload 'mime-preview-play-current-entity "mime-play"
1053 "Play current entity." t)
1055 (defun mime-preview-extract-current-entity ()
1056 "Extract current entity into file (maybe).
1057 It decodes current entity to call internal or external method as
1058 \"extract\" mode. The method is selected from variable
1059 `mime-acting-condition'."
1061 (mime-preview-play-current-entity "extract")
1064 (defun mime-preview-print-current-entity ()
1065 "Print current entity (maybe).
1066 It decodes current entity to call internal or external method as
1067 \"print\" mode. The method is selected from variable
1068 `mime-acting-condition'."
1070 (mime-preview-play-current-entity "print")
1077 (defun mime-preview-follow-current-entity ()
1078 "Write follow message to current entity.
1079 It calls following-method selected from variable
1080 `mime-preview-following-method-alist'."
1083 (while (null (setq entity
1084 (get-text-property (point) 'mime-view-entity)))
1088 (previous-single-property-change (point) 'mime-view-entity))
1090 (entity-node-id (mime-entity-node-id entity))
1091 (len (length entity-node-id))
1095 (if (eq (next-single-property-change (point-min)
1101 ((eq (next-single-property-change p-beg 'mime-view-entity)
1103 (setq p-beg (point))
1105 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1107 (setq p-end (point-max))
1109 ((null entity-node-id)
1110 (setq p-end (point-max))
1118 (next-single-property-change
1119 (point) 'mime-view-entity))
1121 (let ((rc (mime-entity-node-id
1122 (get-text-property (point)
1123 'mime-view-entity))))
1124 (or (equal entity-node-id
1125 (nthcdr (- (length rc) len) rc))
1130 (setq p-end (point-max))
1133 (let* ((mode (mime-preview-original-major-mode 'recursive))
1135 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1137 (the-buf (current-buffer))
1138 (a-buf mime-raw-buffer)
1141 (set-buffer (setq new-buf (get-buffer-create new-name)))
1143 (insert-buffer-substring the-buf p-beg p-end)
1144 (goto-char (point-min))
1145 (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1153 (mime-raw-find-entity-from-node-id entity-node-id))
1156 (mime-entity-point-min ci)
1157 (mime-entity-point-max ci)
1159 (std11-header-string-except
1161 (apply (function regexp-or) fields)
1164 (eq (mime-entity-media-type ci) 'message)
1165 (eq (mime-entity-media-subtype ci) 'rfc822))
1171 (setq fields (std11-collect-field-names)
1172 entity-node-id (cdr entity-node-id))
1175 (let ((rest mime-view-following-required-fields-list))
1177 (let ((field-name (car rest)))
1178 (or (std11-field-body field-name)
1184 (set-buffer the-buf)
1185 (set-buffer mime-mother-buffer)
1186 (set-buffer mime-raw-buffer)
1187 (std11-field-body field-name)
1191 (setq rest (cdr rest))
1193 (eword-decode-header)
1195 (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1200 "Sorry, following method for %s is not implemented yet."
1209 (defun mime-preview-display-x-face ()
1211 (save-window-excursion
1212 (set-buffer mime-raw-buffer)
1213 (mime-view-x-face-function)
1220 (defun mime-preview-move-to-upper ()
1221 "Move to upper entity.
1222 If there is no upper entity, call function `mime-preview-quit'."
1225 (while (null (setq cinfo
1226 (get-text-property (point) 'mime-view-entity)))
1229 (let ((r (mime-raw-find-entity-from-node-id
1230 (cdr (mime-entity-node-id cinfo))
1231 (get-text-property 1 'mime-view-entity)))
1234 (while (setq point (previous-single-property-change
1235 (point) 'mime-view-entity))
1237 (if (eq r (get-text-property (point) 'mime-view-entity))
1244 (defun mime-preview-move-to-previous ()
1245 "Move to previous entity.
1246 If there is no previous entity, it calls function registered in
1247 variable `mime-preview-over-to-previous-method-alist'."
1249 (while (null (get-text-property (point) 'mime-view-entity))
1252 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1254 (if (get-text-property (1- point) 'mime-view-entity)
1256 (goto-char (1- point))
1257 (mime-preview-move-to-previous)
1259 (let ((f (assq (mime-preview-original-major-mode)
1260 mime-preview-over-to-previous-method-alist)))
1266 (defun mime-preview-move-to-next ()
1267 "Move to next entity.
1268 If there is no previous entity, it calls function registered in
1269 variable `mime-preview-over-to-next-method-alist'."
1271 (while (null (get-text-property (point) 'mime-view-entity))
1274 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1278 (if (null (get-text-property point 'mime-view-entity))
1279 (mime-preview-move-to-next)
1281 (let ((f (assq (mime-preview-original-major-mode)
1282 mime-preview-over-to-next-method-alist)))
1288 (defun mime-preview-scroll-up-entity (&optional h)
1289 "Scroll up current entity.
1290 If reached to (point-max), it calls function registered in variable
1291 `mime-preview-over-to-next-method-alist'."
1294 (setq h (1- (window-height)))
1296 (if (= (point) (point-max))
1297 (let ((f (assq (mime-preview-original-major-mode)
1298 mime-preview-over-to-next-method-alist)))
1303 (or (next-single-property-change (point) 'mime-view-entity)
1306 (if (> (point) point)
1311 (defun mime-preview-scroll-down-entity (&optional h)
1312 "Scroll down current entity.
1313 If reached to (point-min), it calls function registered in variable
1314 `mime-preview-over-to-previous-method-alist'."
1317 (setq h (1- (window-height)))
1319 (if (= (point) (point-min))
1320 (let ((f (assq (mime-preview-original-major-mode)
1321 mime-preview-over-to-previous-method-alist)))
1326 (or (previous-single-property-change (point) 'mime-view-entity)
1328 (forward-line (- h))
1329 (if (< (point) point)
1333 (defun mime-preview-next-line-entity ()
1335 (mime-preview-scroll-up-entity 1)
1338 (defun mime-preview-previous-line-entity ()
1340 (mime-preview-scroll-down-entity 1)
1347 (defun mime-preview-quit ()
1348 "Quit from MIME-preview buffer.
1349 It calls function registered in variable
1350 `mime-preview-quitting-method-alist'."
1352 (let ((r (assq (mime-preview-original-major-mode)
1353 mime-preview-quitting-method-alist)))
1358 (defun mime-preview-kill-buffer ()
1360 (kill-buffer (current-buffer))
1367 (provide 'mime-view)
1369 (run-hooks 'mime-view-load-hook)
1371 ;;; mime-view.el ends here