1 ;;; mime-view.el --- interactive MIME viewer for GNU Emacs
3 ;; Copyright (C) 1995,1996,1997,1998,1999 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 (Sample of Elastic 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
42 (concat (mime-product-name mime-user-interface-product) " MIME-View "
43 (mapconcat #'number-to-string
44 (mime-product-version mime-user-interface-product) ".")
45 " (" (mime-product-code-name mime-user-interface-product) ")"))
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-alist
75 '((mime-show-message-mode . binary)
76 (mime-temp-message-mode . binary)
79 "Alist of major-mode vs. representation-type of mime-raw-buffer.
80 Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
81 major-mode or t. t means default. REPRESENTATION-TYPE must be
82 `binary' or `cooked'.")
85 (defun mime-raw-find-entity-from-point (point &optional message-info)
86 "Return entity from POINT in mime-raw-buffer.
87 If optional argument MESSAGE-INFO is not specified,
88 `mime-message-structure' is used."
90 (setq message-info mime-message-structure))
91 (if (and (<= (mime-entity-point-min message-info) point)
92 (<= point (mime-entity-point-max message-info)))
93 (let ((children (mime-entity-children message-info)))
97 (mime-raw-find-entity-from-point point (car children))))
101 (setq children (cdr children)))
105 ;;; @ in preview-buffer (presentation space)
108 (defvar mime-mother-buffer nil
109 "Mother buffer corresponding with the (MIME-preview) buffer.
110 If current MIME-preview buffer is generated by other buffer, such as
111 message/partial, it is called `mother-buffer'.")
112 (make-variable-buffer-local 'mime-mother-buffer)
114 (defvar mime-raw-buffer nil
115 "Raw buffer corresponding with the (MIME-preview) buffer.")
116 (make-variable-buffer-local 'mime-raw-buffer)
118 (defvar mime-preview-original-window-configuration nil
119 "Window-configuration before mime-view-mode is called.")
120 (make-variable-buffer-local 'mime-preview-original-window-configuration)
122 (defun mime-preview-original-major-mode (&optional recursive)
123 "Return major-mode of original buffer.
124 If optional argument RECURSIVE is non-nil and current buffer has
125 mime-mother-buffer, it returns original major-mode of the
127 (if (and recursive mime-mother-buffer)
129 (set-buffer mime-mother-buffer)
130 (mime-preview-original-major-mode recursive)
135 (get-text-property (point-min) 'mime-view-entity)))
139 ;;; @ entity information
142 (defun mime-entity-situation (entity &optional situation)
143 "Return situation of ENTITY."
144 (let (rest param name)
146 (unless (assq 'type situation)
147 (setq rest (or (mime-entity-content-type entity)
148 (make-mime-content-type 'text 'plain))
149 situation (cons (car rest) situation)
152 (unless (assq 'subtype situation)
154 (setq rest (or (cdr (mime-entity-content-type entity))
155 '((subtype . plain)))))
156 (setq situation (cons (car rest) situation)
160 (setq param (car rest))
161 (or (assoc (car param) situation)
162 (setq situation (cons param situation)))
163 (setq rest (cdr rest)))
165 ;; Content-Disposition
167 (unless (assq 'disposition-type situation)
168 (setq rest (mime-entity-content-disposition entity))
170 (setq situation (cons (cons 'disposition-type
171 (mime-content-disposition-type rest))
173 rest (mime-content-disposition-parameters rest))
176 (setq param (car rest)
178 (if (cond ((string= name "filename")
179 (if (assq 'filename situation)
181 (setq name 'filename)))
182 ((string= name "creation-date")
183 (if (assq 'creation-date situation)
185 (setq name 'creation-date)))
186 ((string= name "modification-date")
187 (if (assq 'modification-date situation)
189 (setq name 'modification-date)))
190 ((string= name "read-date")
191 (if (assq 'read-date situation)
193 (setq name 'read-date)))
194 ((string= name "size")
195 (if (assq 'size situation)
198 (t (setq name (cons 'disposition name))
199 (if (assoc name situation)
203 (cons (cons name (cdr param))
205 (setq rest (cdr rest)))
207 ;; Content-Transfer-Encoding
208 (or (assq 'encoding situation)
210 (cons (cons 'encoding (or (mime-entity-encoding entity)
215 (or (assq 'major-mode situation)
217 (cons (cons 'major-mode
218 (with-current-buffer (mime-entity-buffer entity)
224 (defun mime-view-entity-title (entity)
225 (or (mime-read-field 'Content-Description entity)
226 (mime-read-field 'Subject entity)
227 (mime-entity-filename entity)
231 (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
232 "Return entity-node-id from POINT in mime-raw-buffer.
233 If optional argument MESSAGE-INFO is not specified,
234 `mime-message-structure' is used."
235 (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
237 (defsubst mime-raw-point-to-entity-number (point &optional message-info)
238 "Return entity-number from POINT in mime-raw-buffer.
239 If optional argument MESSAGE-INFO is not specified,
240 `mime-message-structure' is used."
241 (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
243 (defun mime-raw-flatten-message-info (&optional message-info)
244 "Return list of entity in mime-raw-buffer.
245 If optional argument MESSAGE-INFO is not specified,
246 `mime-message-structure' is used."
248 (setq message-info mime-message-structure))
249 (let ((dest (list message-info))
250 (rcl (mime-entity-children message-info)))
252 (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
253 (setq rcl (cdr rcl)))
257 ;;; @ presentation of preview
263 ;;; @@@ predicate function
266 (defun mime-view-entity-button-visible-p (entity)
267 "Return non-nil if header of ENTITY is visible.
268 Please redefine this function if you want to change default setting."
269 (let ((media-type (mime-entity-media-type entity))
270 (media-subtype (mime-entity-media-subtype entity)))
271 (or (not (eq media-type 'application))
272 (and (not (eq media-subtype 'x-selection))
273 (or (not (eq media-subtype 'octet-stream))
274 (let ((mother-entity (mime-entity-parent entity)))
275 (or (not (eq (mime-entity-media-type mother-entity)
277 (not (eq (mime-entity-media-subtype mother-entity)
282 ;;; @@@ entity button generator
285 (defun mime-view-insert-entity-button (entity)
286 "Insert entity-button of ENTITY."
287 (let ((entity-node-id (mime-entity-node-id entity))
288 (params (mime-entity-parameters entity))
289 (subject (mime-view-entity-title entity)))
291 (let ((access-type (assoc "access-type" params))
292 (num (or (cdr (assoc "x-part-number" params))
293 (if (consp entity-node-id)
296 (format "%s" (1+ num))
298 (reverse entity-node-id) ".")
302 (let ((server (assoc "server" params)))
303 (setq access-type (cdr access-type))
305 (format "%s %s ([%s] %s)"
306 num subject access-type (cdr server))
307 (let ((site (cdr (assoc "site" params)))
308 (dir (cdr (assoc "directory" params)))
309 (url (cdr (assoc "url" params)))
312 (format "%s %s ([%s] %s)"
313 num subject access-type url)
314 (format "%s %s ([%s] %s:%s)"
315 num subject access-type site dir))
319 (let ((media-type (mime-entity-media-type entity))
320 (media-subtype (mime-entity-media-subtype entity))
321 (charset (cdr (assoc "charset" params)))
322 (encoding (mime-entity-encoding entity)))
326 (format " <%s/%s%s%s>"
327 media-type media-subtype
329 (concat "; " charset)
332 (concat " (" encoding ")")
334 (if (>= (+ (current-column)(length rest))(window-width))
338 (function mime-preview-play-current-entity))
345 (defvar mime-header-presentation-method-alist nil
346 "Alist of major mode vs. corresponding header-presentation-method functions.
347 Each element looks like (SYMBOL . FUNCTION).
348 SYMBOL must be major mode in raw-buffer or t. t means default.
349 Interface of FUNCTION must be (ENTITY SITUATION).")
351 (defvar mime-view-ignored-field-list
352 '(".*Received:" ".*Path:" ".*Id:" "^References:"
353 "^Replied:" "^Errors-To:"
354 "^Lines:" "^Sender:" ".*Host:" "^Xref:"
355 "^Content-Type:" "^Precedence:"
356 "^Status:" "^X-VM-.*:")
357 "All fields that match this list will be hidden in MIME preview buffer.
358 Each elements are regexp of field-name.")
360 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
361 "All fields that match this list will be displayed in MIME preview buffer.
362 Each elements are regexp of field-name.")
368 ;;; @@@ predicate function
371 (defun mime-calist::field-match-method-as-default-rule (calist
372 field-type field-value)
373 (let ((s-field (assq field-type calist)))
374 (cond ((null s-field)
375 (cons (cons field-type field-value) calist)
379 (define-calist-field-match-method
380 'header #'mime-calist::field-match-method-as-default-rule)
382 (define-calist-field-match-method
383 'body #'mime-calist::field-match-method-as-default-rule)
386 (defvar mime-preview-condition nil
387 "Condition-tree about how to display entity.")
389 (ctree-set-calist-strictly
390 'mime-preview-condition '((type . application)(subtype . octet-stream)
393 (ctree-set-calist-strictly
394 'mime-preview-condition '((type . application)(subtype . octet-stream)
397 (ctree-set-calist-strictly
398 'mime-preview-condition '((type . application)(subtype . octet-stream)
402 (ctree-set-calist-strictly
403 'mime-preview-condition '((type . application)(subtype . pgp)
406 (ctree-set-calist-strictly
407 'mime-preview-condition '((type . application)(subtype . x-latex)
410 (ctree-set-calist-strictly
411 'mime-preview-condition '((type . application)(subtype . x-selection)
414 (ctree-set-calist-strictly
415 'mime-preview-condition '((type . application)(subtype . x-comment)
418 (ctree-set-calist-strictly
419 'mime-preview-condition '((type . message)(subtype . delivery-status)
422 (ctree-set-calist-strictly
423 'mime-preview-condition
425 (body-presentation-method . mime-display-text/plain)))
427 (ctree-set-calist-strictly
428 'mime-preview-condition
431 (body-presentation-method . mime-display-text/plain)))
433 (ctree-set-calist-strictly
434 'mime-preview-condition
435 '((type . text)(subtype . enriched)
437 (body-presentation-method . mime-display-text/enriched)))
439 (ctree-set-calist-strictly
440 'mime-preview-condition
441 '((type . text)(subtype . richtext)
443 (body-presentation-method . mime-display-text/richtext)))
445 (ctree-set-calist-strictly
446 'mime-preview-condition
447 '((type . text)(subtype . x-vcard)
449 (body-presentation-method . mime-display-text/x-vcard)))
451 (ctree-set-calist-strictly
452 'mime-preview-condition
453 '((type . application)(subtype . x-postpet)
455 (body-presentation-method . mime-display-application/x-postpet)))
457 (ctree-set-calist-strictly
458 'mime-preview-condition
459 '((type . text)(subtype . t)
461 (body-presentation-method . mime-display-text/plain)))
463 (ctree-set-calist-strictly
464 'mime-preview-condition
465 '((type . multipart)(subtype . alternative)
467 (body-presentation-method . mime-display-multipart/alternative)))
469 (ctree-set-calist-strictly
470 'mime-preview-condition '((type . message)(subtype . partial)
471 (body-presentation-method
472 . mime-display-message/partial-button)))
474 (ctree-set-calist-strictly
475 'mime-preview-condition '((type . message)(subtype . rfc822)
476 (body-presentation-method . nil)
477 (childrens-situation (header . visible)
478 (entity-button . invisible))))
480 (ctree-set-calist-strictly
481 'mime-preview-condition '((type . message)(subtype . news)
482 (body-presentation-method . nil)
483 (childrens-situation (header . visible)
484 (entity-button . invisible))))
487 ;;; @@@ entity presentation
490 (defun mime-display-text/plain (entity situation)
492 (narrow-to-region (point-max)(point-max))
493 (mime-insert-text-content entity)
494 (run-hooks 'mime-text-decode-hook)
495 (goto-char (point-max))
496 (if (not (eq (char-after (1- (point))) ?\n))
499 (mime-add-url-buttons)
500 (run-hooks 'mime-display-text/plain-hook)
503 (defun mime-display-text/richtext (entity situation)
505 (narrow-to-region (point-max)(point-max))
506 (mime-insert-text-content entity)
507 (run-hooks 'mime-text-decode-hook)
508 (let ((beg (point-min)))
509 (remove-text-properties beg (point-max) '(face nil))
510 (richtext-decode beg (point-max))
513 (defun mime-display-text/enriched (entity situation)
515 (narrow-to-region (point-max)(point-max))
516 (mime-insert-text-content entity)
517 (run-hooks 'mime-text-decode-hook)
518 (let ((beg (point-min)))
519 (remove-text-properties beg (point-max) '(face nil))
520 (enriched-decode beg (point-max))
523 (defun mime-display-text/x-vcard (entity situation)
525 (narrow-to-region (point-max)(point-max))
526 (insert (string-as-multibyte (mime-entity-content entity)))
527 (goto-char (point-min))
528 (while (re-search-forward
529 "\\(;\\(encoding=\\)?quoted-printable:\\)\\(\\(=[0-9A-F][0-9A-F]\\|=\r?\n\\|[^\r\n]\\)*\\)"
533 (buffer-substring (match-beginning 1) (match-end 1))
536 (decode-coding-string
537 (buffer-substring (match-beginning 3) (match-end 3)) 'raw-text-dos)
538 "quoted-printable")))
540 (decode-coding-region (point-min) (point-max) 'undecided)
541 (goto-char (point-max))
542 (if (not (eq (char-after (1- (point))) ?\n))
544 (mime-add-url-buttons)
545 (run-hooks 'mime-display-text/x-vcard-hook)
548 (put 'unpack 'lisp-indent-function 1)
549 (defmacro unpack (string &rest body)
550 `(let* ((*unpack*string* (string-as-unibyte ,string))
552 (*unpack*length* (length *unpack*string*)))
555 (defun unpack-skip (len)
556 (setq *unpack*index* (+ len *unpack*index*)))
558 (defun unpack-fixed (len)
560 (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
563 (defun unpack-byte ()
564 (char-int (aref (unpack-fixed 1) 0)))
566 (defun unpack-short ()
567 (let* ((b0 (unpack-byte))
571 (defun unpack-long ()
572 (let* ((s0 (unpack-short))
574 (+ (* 65536 s0) s1)))
576 (defun unpack-string ()
577 (let ((len (unpack-byte)))
580 (defun unpack-string-sjis ()
581 (decode-mime-charset-string (unpack-string) 'shift_jis))
583 (defun postpet-decode (string)
587 (set-alist 'res 'carryingcount (unpack-long))
589 (set-alist 'res 'sentyear (unpack-short))
590 (set-alist 'res 'sentmonth (unpack-short))
591 (set-alist 'res 'sentday (unpack-short))
593 (set-alist 'res 'petname (unpack-string-sjis))
594 (set-alist 'res 'owner (unpack-string-sjis))
595 (set-alist 'res 'pettype (unpack-fixed 4))
596 (set-alist 'res 'health (unpack-short))
598 (set-alist 'res 'sex (unpack-long))
600 (set-alist 'res 'brain (unpack-byte))
602 (set-alist 'res 'happiness (unpack-byte))
604 (set-alist 'res 'petbirthyear (unpack-short))
605 (set-alist 'res 'petbirthmonth (unpack-short))
606 (set-alist 'res 'petbirthday (unpack-short))
608 (set-alist 'res 'from (unpack-string))
615 (set-alist 'res 'treasure (unpack-short))
616 (set-alist 'res 'money (unpack-long))
619 (defun mime-display-application/x-postpet (entity situation)
621 (narrow-to-region (point-max)(point-max))
622 (let ((pet (postpet-decode (string-as-unibyte (mime-entity-content entity)))))
623 (insert "Petname: " (cdr (assq 'petname pet)) "\n"
624 "Owner: " (cdr (assq 'owner pet)) "\n"
625 "Pettype: " (cdr (assq 'pettype pet)) "\n"
626 "From: " (cdr (assq 'from pet)) "\n"
627 "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n"
628 "SentYaer: " (int-to-string (cdr (assq 'sentyear pet))) "\n"
629 "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n"
630 "Sentday: " (int-to-string (cdr (assq 'sentday pet))) "\n"
631 "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n"
632 "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n"
633 "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n"
634 "Health: " (int-to-string (cdr (assq 'health pet))) "\n"
635 "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n"
636 "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n"
637 "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n"
638 "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n"
639 "Money: " (int-to-string (cdr (assq 'money pet))) "\n"
641 (run-hooks 'mime-display-application/x-postpet-hook))))
643 (defvar mime-view-announcement-for-message/partial
644 (if (and (>= emacs-major-version 19) window-system)
646 \[[ This is message/partial style split message. ]]
647 \[[ Please press `v' key in this buffer ]]
648 \[[ or click here by mouse button-2. ]]"
650 \[[ This is message/partial style split message. ]]
651 \[[ Please press `v' key in this buffer. ]]"
654 (defun mime-display-message/partial-button (&optional entity situation)
656 (goto-char (point-max))
657 (if (not (search-backward "\n\n" nil t))
660 (goto-char (point-max))
661 (narrow-to-region (point-max)(point-max))
662 (insert mime-view-announcement-for-message/partial)
663 (mime-add-button (point-min)(point-max)
664 #'mime-preview-play-current-entity)
667 (defun mime-display-multipart/mixed (entity situation)
668 (let ((children (mime-entity-children entity))
670 (cdr (assq 'childrens-situation situation))))
672 (mime-display-entity (car children) nil default-situation)
673 (setq children (cdr children))
676 (defcustom mime-view-type-subtype-score-alist
677 '(((text . enriched) . 3)
678 ((text . richtext) . 2)
681 "Alist MEDIA-TYPE vs corresponding score.
682 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
684 :type '(repeat (cons (choice :tag "Media-Type"
685 (cons :tag "Type/Subtype"
686 (symbol :tag "Primary-type")
687 (symbol :tag "Subtype"))
689 (const :tag "Default" t))
692 (defun mime-display-multipart/alternative (entity situation)
693 (let* ((children (mime-entity-children entity))
695 (cdr (assq 'childrens-situation situation)))
703 (or (ctree-match-calist
704 mime-preview-condition
705 (append (mime-entity-situation child)
708 (if (cdr (assq 'body-presentation-method situation))
713 (cdr (assq 'type situation))
714 (cdr (assq 'subtype situation)))
715 mime-view-type-subtype-score-alist)
717 (cdr (assq 'type situation))
718 mime-view-type-subtype-score-alist)
721 mime-view-type-subtype-score-alist)
723 (if (> score max-score)
733 (let ((child (car children))
734 (situation (car situations)))
735 (mime-display-entity child (if (= i p)
737 (del-alist 'body-presentation-method
738 (copy-alist situation))))
740 (setq children (cdr children)
741 situations (cdr situations)
746 ;;; @ acting-condition
749 (defvar mime-acting-condition nil
750 "Condition-tree about how to process entity.")
752 (if (file-readable-p mailcap-file)
753 (let ((entries (mailcap-parse-file)))
755 (let ((entry (car entries))
758 (let* ((field (car entry))
759 (field-type (car field)))
760 (cond ((eq field-type 'view) (setq view field))
761 ((eq field-type 'print) (setq print field))
762 ((memq field-type '(compose composetyped edit)))
763 (t (setq shared (cons field shared))))
765 (setq entry (cdr entry))
767 (setq shared (nreverse shared))
768 (ctree-set-calist-with-default
769 'mime-acting-condition
770 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
772 (ctree-set-calist-with-default
773 'mime-acting-condition
775 (list '(mode . "print")(cons 'method (cdr view))))
778 (setq entries (cdr entries))
781 (ctree-set-calist-strictly
782 'mime-acting-condition
783 '((type . application)(subtype . octet-stream)
785 (method . mime-detect-content)
788 (ctree-set-calist-with-default
789 'mime-acting-condition
791 (method . mime-save-content)))
793 (ctree-set-calist-strictly
794 'mime-acting-condition
795 '((type . text)(subtype . x-rot13-47)(mode . "play")
796 (method . mime-view-caesar)
798 (ctree-set-calist-strictly
799 'mime-acting-condition
800 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
801 (method . mime-view-caesar)
804 (ctree-set-calist-strictly
805 'mime-acting-condition
806 '((type . message)(subtype . rfc822)(mode . "play")
807 (method . mime-view-message/rfc822)
809 (ctree-set-calist-strictly
810 'mime-acting-condition
811 '((type . message)(subtype . partial)(mode . "play")
812 (method . mime-store-message/partial-piece)
815 (ctree-set-calist-strictly
816 'mime-acting-condition
817 '((type . message)(subtype . external-body)
818 ("access-type" . "anon-ftp")
819 (method . mime-view-message/external-anon-ftp)
822 (ctree-set-calist-strictly
823 'mime-acting-condition
824 '((type . message)(subtype . external-body)
825 ("access-type" . "url")
826 (method . mime-view-message/external-url)
829 (ctree-set-calist-strictly
830 'mime-acting-condition
831 '((type . application)(subtype . octet-stream)
832 (method . mime-save-content)
836 ;;; @ quitting method
839 (defvar mime-preview-quitting-method-alist
840 '((mime-show-message-mode
841 . mime-preview-quitting-method-for-mime-show-message-mode))
842 "Alist of major-mode vs. quitting-method of mime-view.")
844 (defvar mime-preview-over-to-previous-method-alist nil
845 "Alist of major-mode vs. over-to-previous-method of mime-view.")
847 (defvar mime-preview-over-to-next-method-alist nil
848 "Alist of major-mode vs. over-to-next-method of mime-view.")
851 ;;; @ following method
854 (defvar mime-preview-following-method-alist nil
855 "Alist of major-mode vs. following-method of mime-view.")
857 (defvar mime-view-following-required-fields-list
864 (defun mime-display-entity (entity &optional situation
865 default-situation preview-buffer)
867 (setq preview-buffer (current-buffer)))
868 (let* ((raw-buffer (mime-entity-buffer entity))
869 (start (mime-entity-point-min entity))
871 (set-buffer raw-buffer)
875 (or (ctree-match-calist mime-preview-condition
876 (append (mime-entity-situation entity)
879 (let ((button-is-invisible
880 (eq (cdr (assq 'entity-button situation)) 'invisible))
882 (eq (cdr (assq 'header situation)) 'visible))
883 (header-presentation-method
884 (or (cdr (assq 'header-presentation-method situation))
885 (cdr (assq major-mode mime-header-presentation-method-alist))))
886 (body-presentation-method
887 (cdr (assq 'body-presentation-method situation)))
888 (children (mime-entity-children entity)))
889 (set-buffer preview-buffer)
891 (narrow-to-region nb nb)
892 (or button-is-invisible
893 (if (mime-view-entity-button-visible-p entity)
894 (mime-view-insert-entity-button entity)
896 (when header-is-visible
897 (if header-presentation-method
898 (funcall header-presentation-method entity situation)
899 (mime-insert-header entity
900 mime-view-ignored-field-list
901 mime-view-visible-field-list))
902 (goto-char (point-max))
904 (run-hooks 'mime-display-header-hook)
907 ((functionp body-presentation-method)
908 (funcall body-presentation-method entity situation)
911 (when button-is-invisible
912 (goto-char (point-max))
913 (mime-view-insert-entity-button entity)
915 (or header-is-visible
917 (goto-char (point-max))
921 (setq ne (point-max))
923 (put-text-property nb ne 'mime-view-entity entity)
926 (if (functionp body-presentation-method)
927 (funcall body-presentation-method entity situation)
928 (mime-display-multipart/mixed entity situation)
933 ;;; @ MIME viewer mode
936 (defconst mime-view-menu-title "MIME-View")
937 (defconst mime-view-menu-list
938 '((up "Move to upper entity" mime-preview-move-to-upper)
939 (previous "Move to previous entity" mime-preview-move-to-previous)
940 (next "Move to next entity" mime-preview-move-to-next)
941 (scroll-down "Scroll-down" mime-preview-scroll-down-entity)
942 (scroll-up "Scroll-up" mime-preview-scroll-up-entity)
943 (play "Play current entity" mime-preview-play-current-entity)
944 (extract "Extract current entity" mime-preview-extract-current-entity)
945 (print "Print current entity" mime-preview-print-current-entity)
947 "Menu for MIME Viewer")
949 (cond ((featurep 'xemacs)
950 (defvar mime-view-xemacs-popup-menu
951 (cons mime-view-menu-title
954 (vector (nth 1 item)(nth 2 item) t)
956 mime-view-menu-list)))
957 (defun mime-view-xemacs-popup-menu (event)
958 "Popup the menu in the MIME Viewer buffer"
960 (select-window (event-window event))
961 (set-buffer (event-buffer event))
962 (popup-menu 'mime-view-xemacs-popup-menu))
963 (defvar mouse-button-2 'button2)
966 (defvar mouse-button-2 [mouse-2])
969 (defun mime-view-define-keymap (&optional default)
970 (let ((mime-view-mode-map (if (keymapp default)
971 (copy-keymap default)
974 (define-key mime-view-mode-map
975 "u" (function mime-preview-move-to-upper))
976 (define-key mime-view-mode-map
977 "p" (function mime-preview-move-to-previous))
978 (define-key mime-view-mode-map
979 "n" (function mime-preview-move-to-next))
980 (define-key mime-view-mode-map
981 "\e\t" (function mime-preview-move-to-previous))
982 (define-key mime-view-mode-map
983 "\t" (function mime-preview-move-to-next))
984 (define-key mime-view-mode-map
985 " " (function mime-preview-scroll-up-entity))
986 (define-key mime-view-mode-map
987 "\M- " (function mime-preview-scroll-down-entity))
988 (define-key mime-view-mode-map
989 "\177" (function mime-preview-scroll-down-entity))
990 (define-key mime-view-mode-map
991 "\C-m" (function mime-preview-next-line-entity))
992 (define-key mime-view-mode-map
993 "\C-\M-m" (function mime-preview-previous-line-entity))
994 (define-key mime-view-mode-map
995 "v" (function mime-preview-play-current-entity))
996 (define-key mime-view-mode-map
997 "e" (function mime-preview-extract-current-entity))
998 (define-key mime-view-mode-map
999 "\C-c\C-p" (function mime-preview-print-current-entity))
1000 (define-key mime-view-mode-map
1001 "a" (function mime-preview-follow-current-entity))
1002 (define-key mime-view-mode-map
1003 "q" (function mime-preview-quit))
1004 (define-key mime-view-mode-map
1005 "\C-c\C-x" (function mime-preview-kill-buffer))
1006 ;; (define-key mime-view-mode-map
1007 ;; "<" (function beginning-of-buffer))
1008 ;; (define-key mime-view-mode-map
1009 ;; ">" (function end-of-buffer))
1010 (define-key mime-view-mode-map
1011 "?" (function describe-mode))
1012 (define-key mime-view-mode-map
1013 [tab] (function mime-preview-move-to-next))
1014 (define-key mime-view-mode-map
1015 [delete] (function mime-preview-scroll-down-entity))
1016 (define-key mime-view-mode-map
1017 [backspace] (function mime-preview-scroll-down-entity))
1018 (if (functionp default)
1019 (cond ((featurep 'xemacs)
1020 (set-keymap-default-binding mime-view-mode-map default)
1023 (setq mime-view-mode-map
1024 (append mime-view-mode-map (list (cons t default))))
1027 (define-key mime-view-mode-map
1028 mouse-button-2 (function mime-button-dispatcher))
1030 (cond ((featurep 'xemacs)
1031 (define-key mime-view-mode-map
1032 mouse-button-3 (function mime-view-xemacs-popup-menu))
1034 ((>= emacs-major-version 19)
1035 (define-key mime-view-mode-map [menu-bar mime-view]
1036 (cons mime-view-menu-title
1037 (make-sparse-keymap mime-view-menu-title)))
1040 (define-key mime-view-mode-map
1041 (vector 'menu-bar 'mime-view (car item))
1042 (cons (nth 1 item)(nth 2 item))
1045 (reverse mime-view-menu-list)
1048 (use-local-map mime-view-mode-map)
1049 (run-hooks 'mime-view-define-keymap-hook)
1052 (defsubst mime-maybe-hide-echo-buffer ()
1053 "Clear mime-echo buffer and delete window for it."
1054 (let ((buf (get-buffer mime-echo-buffer-name)))
1059 (let ((win (get-buffer-window buf)))
1066 (defvar mime-view-redisplay nil)
1069 (defun mime-display-message (message &optional preview-buffer
1070 mother default-keymap-or-function)
1071 "View MESSAGE in MIME-View mode.
1073 Optional argument PREVIEW-BUFFER specifies the buffer of the
1074 presentation. It must be either nil or a name of preview buffer.
1076 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1078 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1079 function. If it is a keymap, keymap of MIME-View mode will be added
1080 to it. If it is a function, it will be bound as default binding of
1081 keymap of MIME-View mode."
1082 (mime-maybe-hide-echo-buffer)
1083 (let ((win-conf (current-window-configuration))
1084 (raw-buffer (mime-entity-buffer message)))
1086 (setq preview-buffer
1087 (concat "*Preview-" (buffer-name raw-buffer) "*")))
1088 (set-buffer raw-buffer)
1089 (setq mime-preview-buffer preview-buffer)
1090 (let ((inhibit-read-only t))
1091 (set-buffer (get-buffer-create preview-buffer))
1094 (setq mime-raw-buffer raw-buffer)
1096 (setq mime-mother-buffer mother)
1098 (setq mime-preview-original-window-configuration win-conf)
1099 (setq major-mode 'mime-view-mode)
1100 (setq mode-name "MIME-View")
1101 (mime-display-entity message nil
1102 '((entity-button . invisible)
1105 (mime-view-define-keymap default-keymap-or-function)
1107 (next-single-property-change (point-min) 'mime-view-entity)))
1110 (goto-char (point-min))
1111 (search-forward "\n\n" nil t)
1113 (run-hooks 'mime-view-mode-hook)
1114 (set-buffer-modified-p nil)
1115 (setq buffer-read-only t)
1116 (or (get-buffer-window preview-buffer)
1117 (let ((r-win (get-buffer-window raw-buffer)))
1119 (set-window-buffer r-win preview-buffer)
1120 (let ((m-win (and mother (get-buffer-window mother))))
1122 (set-window-buffer m-win preview-buffer)
1123 (switch-to-buffer preview-buffer)
1128 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1129 default-keymap-or-function
1130 representation-type)
1131 "View RAW-BUFFER in MIME-View mode.
1132 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1134 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1135 function. If it is a keymap, keymap of MIME-View mode will be added
1136 to it. If it is a function, it will be bound as default binding of
1137 keymap of MIME-View mode.
1138 Optional argument REPRESENTATION-TYPE is representation-type of
1139 message. It must be nil, `binary' or `cooked'. If it is nil,
1140 `cooked' is used as default."
1143 (setq raw-buffer (current-buffer)))
1144 (or representation-type
1145 (setq representation-type
1147 (set-buffer raw-buffer)
1148 (cdr (or (assq major-mode mime-raw-representation-type-alist)
1149 (assq t mime-raw-representation-type-alist)))
1151 (if (eq representation-type 'binary)
1152 (setq representation-type 'buffer)
1154 (mime-display-message
1155 (mime-open-entity representation-type raw-buffer)
1156 preview-buffer mother default-keymap-or-function))
1158 (defun mime-view-mode (&optional mother ctl encoding
1159 raw-buffer preview-buffer
1160 default-keymap-or-function)
1161 "Major mode for viewing MIME message.
1163 Here is a list of the standard keys for mime-view-mode.
1168 u Move to upper content
1169 p or M-TAB Move to previous content
1170 n or TAB Move to next content
1171 SPC Scroll up or move to next content
1172 M-SPC or DEL Scroll down or move to previous content
1173 RET Move to next line
1174 M-RET Move to previous line
1175 v Decode current content as `play mode'
1176 e Decode current content as `extract mode'
1177 C-c C-p Decode current content as `print mode'
1178 a Followup to current content.
1180 button-2 Move to point under the mouse cursor
1181 and decode current content as `play mode'
1184 (unless mime-view-redisplay
1186 (if raw-buffer (set-buffer raw-buffer))
1189 (or (assq major-mode mime-raw-representation-type-alist)
1190 (assq t mime-raw-representation-type-alist)))))
1191 (if (eq type 'binary)
1194 (setq mime-message-structure (mime-open-entity type raw-buffer))
1195 (or (mime-entity-content-type mime-message-structure)
1196 (mime-entity-set-content-type-internal
1197 mime-message-structure ctl))
1199 (or (mime-entity-encoding mime-message-structure)
1200 (mime-entity-set-encoding-internal mime-message-structure encoding))
1202 (mime-display-message mime-message-structure preview-buffer
1203 mother default-keymap-or-function)
1210 (autoload 'mime-preview-play-current-entity "mime-play"
1211 "Play current entity." t)
1213 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1214 "Extract current entity into file (maybe).
1215 It decodes current entity to call internal or external method as
1216 \"extract\" mode. The method is selected from variable
1217 `mime-acting-condition'."
1219 (mime-preview-play-current-entity ignore-examples "extract")
1222 (defun mime-preview-print-current-entity (&optional ignore-examples)
1223 "Print current entity (maybe).
1224 It decodes current entity to call internal or external method as
1225 \"print\" mode. The method is selected from variable
1226 `mime-acting-condition'."
1228 (mime-preview-play-current-entity ignore-examples "print")
1235 (defun mime-preview-follow-current-entity ()
1236 "Write follow message to current entity.
1237 It calls following-method selected from variable
1238 `mime-preview-following-method-alist'."
1241 (while (null (setq entity
1242 (get-text-property (point) 'mime-view-entity)))
1246 (previous-single-property-change (point) 'mime-view-entity))
1248 (entity-node-id (mime-entity-node-id entity))
1249 (len (length entity-node-id))
1253 (if (eq (next-single-property-change (point-min)
1259 ((eq (next-single-property-change p-beg 'mime-view-entity)
1261 (setq p-beg (point))
1263 (setq p-end (next-single-property-change p-beg 'mime-view-entity))
1265 (setq p-end (point-max))
1267 ((null entity-node-id)
1268 (setq p-end (point-max))
1276 (next-single-property-change
1277 (point) 'mime-view-entity))
1279 (let ((rc (mime-entity-node-id
1280 (get-text-property (point)
1281 'mime-view-entity))))
1282 (or (equal entity-node-id
1283 (nthcdr (- (length rc) len) rc))
1288 (setq p-end (point-max))
1291 (let* ((mode (mime-preview-original-major-mode 'recursive))
1293 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1295 (the-buf (current-buffer))
1296 (a-buf mime-raw-buffer)
1299 (set-buffer (setq new-buf (get-buffer-create new-name)))
1301 (insert-buffer-substring the-buf p-beg p-end)
1302 (goto-char (point-min))
1303 (let ((entity-node-id (mime-entity-node-id entity)) ci str)
1310 (mime-find-entity-from-node-id entity-node-id))
1313 (mime-entity-point-min ci)
1314 (mime-entity-point-max ci)
1316 (std11-header-string-except
1318 (apply (function regexp-or) fields)
1321 (eq (mime-entity-media-type ci) 'message)
1322 (eq (mime-entity-media-subtype ci) 'rfc822))
1328 (setq fields (std11-collect-field-names)
1329 entity-node-id (cdr entity-node-id))
1332 (let ((rest mime-view-following-required-fields-list))
1334 (let ((field-name (car rest)))
1335 (or (std11-field-body field-name)
1341 (set-buffer the-buf)
1342 (set-buffer mime-mother-buffer)
1343 (set-buffer mime-raw-buffer)
1344 (std11-field-body field-name)
1348 (setq rest (cdr rest))
1350 (mime-decode-header-in-buffer)
1352 (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1357 "Sorry, following method for %s is not implemented yet."
1366 (defun mime-preview-move-to-upper ()
1367 "Move to upper entity.
1368 If there is no upper entity, call function `mime-preview-quit'."
1371 (while (null (setq cinfo
1372 (get-text-property (point) 'mime-view-entity)))
1375 (let ((r (mime-entity-parent cinfo))
1378 (while (setq point (previous-single-property-change
1379 (point) 'mime-view-entity))
1381 (if (eq r (get-text-property (point) 'mime-view-entity))
1388 (defun mime-preview-move-to-previous ()
1389 "Move to previous entity.
1390 If there is no previous entity, it calls function registered in
1391 variable `mime-preview-over-to-previous-method-alist'."
1393 (while (null (get-text-property (point) 'mime-view-entity))
1396 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1398 (if (get-text-property (1- point) 'mime-view-entity)
1400 (goto-char (1- point))
1401 (mime-preview-move-to-previous)
1403 (let ((f (assq (mime-preview-original-major-mode)
1404 mime-preview-over-to-previous-method-alist)))
1410 (defun mime-preview-move-to-next ()
1411 "Move to next entity.
1412 If there is no previous entity, it calls function registered in
1413 variable `mime-preview-over-to-next-method-alist'."
1415 (while (and (not (eobp))
1416 (null (get-text-property (point) 'mime-view-entity)))
1419 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1423 (if (null (get-text-property point 'mime-view-entity))
1424 (mime-preview-move-to-next)
1426 (let ((f (assq (mime-preview-original-major-mode)
1427 mime-preview-over-to-next-method-alist)))
1433 (defun mime-preview-scroll-up-entity (&optional h)
1434 "Scroll up current entity.
1435 If reached to (point-max), it calls function registered in variable
1436 `mime-preview-over-to-next-method-alist'."
1439 (setq h (1- (window-height)))
1441 (if (= (point) (point-max))
1442 (let ((f (assq (mime-preview-original-major-mode)
1443 mime-preview-over-to-next-method-alist)))
1448 (or (next-single-property-change (point) 'mime-view-entity)
1451 (if (> (point) point)
1456 (defun mime-preview-scroll-down-entity (&optional h)
1457 "Scroll down current entity.
1458 If reached to (point-min), it calls function registered in variable
1459 `mime-preview-over-to-previous-method-alist'."
1462 (setq h (1- (window-height)))
1464 (if (= (point) (point-min))
1465 (let ((f (assq (mime-preview-original-major-mode)
1466 mime-preview-over-to-previous-method-alist)))
1471 (or (previous-single-property-change (point) 'mime-view-entity)
1473 (forward-line (- h))
1474 (if (< (point) point)
1478 (defun mime-preview-next-line-entity ()
1480 (mime-preview-scroll-up-entity 1)
1483 (defun mime-preview-previous-line-entity ()
1485 (mime-preview-scroll-down-entity 1)
1492 (defun mime-preview-quit ()
1493 "Quit from MIME-preview buffer.
1494 It calls function registered in variable
1495 `mime-preview-quitting-method-alist'."
1497 (let ((r (assq (mime-preview-original-major-mode)
1498 mime-preview-quitting-method-alist)))
1503 (defun mime-preview-kill-buffer ()
1505 (kill-buffer (current-buffer))
1512 (provide 'mime-view)
1514 (run-hooks 'mime-view-load-hook)
1516 ;;; mime-view.el ends here