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."
65 (defcustom mime-preview-move-scroll nil
66 "*Decides whether to scroll when moving to next entity.
67 When t, scroll the buffer. Non-nil but not t means scroll when
68 the next entity is within `next-screen-context-lines' from top or
69 buttom. Nil means don't scroll at all."
71 :type '(choice (const :tag "Off" nil)
73 (sexp :tag "Situation" 1)))
75 (defcustom mime-preview-scroll-full-screen nil
76 "*When non-nil, always scroll full screen.
77 If nil, point will be moved to the next entity if exists."
79 :type '(choice (const :tag "On" t)
80 (const :tag "Off" nil)))
82 (defcustom mime-view-force-inline-types '(text multipart)
83 "*List of MIME types that \"attachment\" should be ignored.
84 The element can be type or type/subtype. When t, inline everything
87 :type '(choice (const :tag "Nothing" nil)
89 (list (repeat symbol))))
91 (defcustom mime-view-button-place-alist
93 (application . before)
94 (multipart/alternative . around))
95 "*Alist of MIME type or type/subtype vs. button place.
96 When around, button will be inserted before and after that part.
97 When after or before, button will be inserted that place.
98 If not specified, that type will not have button."
100 :type '(choice (const :tag "Nothing" nil)
101 (list (repeat symbol))))
104 (defcustom mime-view-type-subtype-score-alist
105 '(((text . enriched) . 3)
106 ((text . richtext) . 2)
109 "Alist MEDIA-TYPE vs corresponding score.
110 MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
112 :type '(repeat (cons (choice :tag "Media-Type"
113 (cons :tag "Type/Subtype"
114 (symbol :tag "Primary-type")
115 (symbol :tag "Subtype"))
117 (const :tag "Default" t))
120 (defvar mime-view-automatic-conversion
121 (cond ((featurep 'xemacs)
122 'automatic-conversion)
128 ;;; @ in raw-buffer (representation space)
131 (defvar mime-preview-buffer nil
132 "MIME-preview buffer corresponding with the (raw) buffer.")
133 (make-variable-buffer-local 'mime-preview-buffer)
136 (defvar mime-raw-representation-type-alist
137 '((mime-show-message-mode . binary)
138 (mime-temp-message-mode . binary)
140 "Alist of `major-mode' vs. representation-type of mime-raw-buffer.
141 Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is
142 `major-mode' or t. t means default. REPRESENTATION-TYPE must be
143 `binary' or `cooked'.")
146 ;; (defun mime-raw-find-entity-from-point (point &optional message-info)
147 ;; "Return entity from POINT in mime-raw-buffer.
148 ;; If optional argument MESSAGE-INFO is not specified,
149 ;; `mime-message-structure' is used."
151 ;; (setq message-info mime-message-structure))
152 ;; (if (and (<= (mime-entity-point-min message-info) point)
153 ;; (<= point (mime-entity-point-max message-info)))
154 ;; (let ((children (mime-entity-children message-info)))
158 ;; (mime-raw-find-entity-from-point point (car children))))
162 ;; (setq children (cdr children)))
164 ;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.")
167 ;;; @ in preview-buffer (presentation space)
170 (defvar mime-mother-buffer nil
171 "Mother buffer corresponding with the (MIME-preview) buffer.
172 If current MIME-preview buffer is generated by other buffer, such as
173 message/partial, it is called `mother-buffer'.")
174 (make-variable-buffer-local 'mime-mother-buffer)
176 ;; (defvar mime-raw-buffer nil
177 ;; "Raw buffer corresponding with the (MIME-preview) buffer.")
178 ;; (make-variable-buffer-local 'mime-raw-buffer)
180 (defvar mime-preview-original-window-configuration nil
181 "Window-configuration before `mime-view-mode' is called.")
182 (make-variable-buffer-local 'mime-preview-original-window-configuration)
184 (defun mime-preview-original-major-mode (&optional recursive point)
185 "Return major-mode of original buffer.
186 If optional argument RECURSIVE is non-nil and current buffer has
187 mime-mother-buffer, it returns original major-mode of the
189 (if (and recursive mime-mother-buffer)
191 (set-buffer mime-mother-buffer)
192 (mime-preview-original-major-mode recursive))
193 (cdr (assq 'major-mode
194 (get-text-property (or point
195 (if (> (point) (buffer-size))
196 (max (1- (point-max)) (point-min))
198 'mime-view-situation)))))
201 ;;; @ entity information
204 (defun mime-entity-situation (entity &optional situation)
205 "Return situation of ENTITY."
206 (let (rest param name)
208 (unless (assq 'type situation)
209 (setq rest (or (mime-entity-content-type entity)
210 (make-mime-content-type 'text 'plain))
211 situation (cons (car rest) situation)
213 (unless (assq 'subtype situation)
215 (setq rest (or (cdr (mime-entity-content-type entity))
216 '((subtype . plain)))))
217 (setq situation (cons (car rest) situation)
220 (setq param (car rest))
221 (or (assoc (car param) situation)
222 (setq situation (cons param situation)))
223 (setq rest (cdr rest)))
225 ;; Content-Disposition
227 (unless (assq 'disposition-type situation)
228 (setq rest (mime-entity-content-disposition entity))
230 (setq situation (cons (cons 'disposition-type
231 (mime-content-disposition-type rest))
233 rest (mime-content-disposition-parameters rest))))
235 (setq param (car rest)
237 (if (cond ((string= name "filename")
238 (if (assq 'filename situation)
240 (setq name 'filename)))
241 ((string= name "creation-date")
242 (if (assq 'creation-date situation)
244 (setq name 'creation-date)))
245 ((string= name "modification-date")
246 (if (assq 'modification-date situation)
248 (setq name 'modification-date)))
249 ((string= name "read-date")
250 (if (assq 'read-date situation)
252 (setq name 'read-date)))
253 ((string= name "size")
254 (if (assq 'size situation)
257 (t (setq name (cons 'disposition name))
258 (if (assoc name situation)
262 (cons (cons name (cdr param))
264 (setq rest (cdr rest)))
266 ;; Content-Transfer-Encoding
267 (or (assq 'encoding situation)
269 (cons (cons 'encoding (or (mime-entity-encoding entity)
275 (defun mime-view-entity-title (entity)
276 (or (mime-entity-read-field entity 'Content-Description)
277 (mime-entity-read-field entity 'Subject)
278 (mime-entity-filename entity)
282 ;; (defsubst mime-raw-point-to-entity-node-id (point &optional message-info)
283 ;; "Return entity-node-id from POINT in mime-raw-buffer.
284 ;; If optional argument MESSAGE-INFO is not specified,
285 ;; `mime-message-structure' is used."
286 ;; (mime-entity-node-id (mime-raw-find-entity-from-point point message-info)))
288 ;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.")
290 ;; (defsubst mime-raw-point-to-entity-number (point &optional message-info)
291 ;; "Return entity-number from POINT in mime-raw-buffer.
292 ;; If optional argument MESSAGE-INFO is not specified,
293 ;; `mime-message-structure' is used."
294 ;; (mime-entity-number (mime-raw-find-entity-from-point point message-info)))
296 ;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.")
298 ;; (defun mime-raw-flatten-message-info (&optional message-info)
299 ;; "Return list of entity in mime-raw-buffer.
300 ;; If optional argument MESSAGE-INFO is not specified,
301 ;; `mime-message-structure' is used."
303 ;; (setq message-info mime-message-structure))
304 ;; (let ((dest (list message-info))
305 ;; (rcl (mime-entity-children message-info)))
307 ;; (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl))))
308 ;; (setq rcl (cdr rcl)))
311 (defmacro mime-view-header-is-visible (situation)
312 `(eq (cdr (or (assq '*header ,situation)
313 (assq 'header ,situation)))
316 (defmacro mime-view-body-is-visible (situation)
317 `(eq (cdr (or (assq '*body ,situation)
318 (assq 'body ,situation)))
321 (defmacro mime-view-children-is-invisible (situation)
322 `(eq (cdr (or (assq '*children ,situation)
323 (assq 'children ,situation)))
326 (defmacro mime-view-button-is-visible (situation)
328 `(or (eq (or (cdr (assq '*entity-button ,situation))
329 (cdr (assq 'entity-button ,situation)))
331 (and (not (eq (or (cdr (assq '*entity-button ,situation))
332 (cdr (assq 'entity-button ,situation)))
334 (mime-view-entity-button-visible-p entity))))
336 ;;; @ presentation of preview
342 ;;; @@@ predicate function
346 (defun mime-view-entity-type/subtype (entity)
347 (if (not (mime-entity-media-type entity))
349 (intern (format "%s/%s"
350 (mime-entity-media-type entity)
351 (mime-entity-media-subtype entity)))))
353 (defun mime-view-entity-button-visible-p (entity)
354 "Return non-nil if header of ENTITY is visible.
355 You can customize the visibility by changing `mime-view-button-place-alist'."
357 ;; Check current entity
359 (memq (cdr (assq (mime-view-entity-type/subtype entity)
360 mime-view-button-place-alist))
363 (memq (cdr (assq (mime-entity-media-type entity)
364 mime-view-button-place-alist))
366 (and (mime-entity-parent entity)
369 (reverse (mime-entity-children
370 (mime-entity-parent entity)))))))
371 ;; When previous entity exists
374 ;; Check previous entity
378 (mime-view-entity-type/subtype prev-entity)
379 mime-view-button-place-alist))
384 (mime-entity-media-type prev-entity)
385 mime-view-button-place-alist))
387 ;; default for everything.
389 mime-view-button-place-alist))
392 ;;; @@@ entity button generator
395 (defun mime-view-insert-entity-button (entity &optional body-is-invisible)
396 "Insert entity-button of ENTITY."
397 (let ((entity-node-id (mime-entity-node-id entity))
398 (params (mime-entity-parameters entity))
399 (subject (mime-view-entity-title entity)))
402 (let ((access-type (assoc "access-type" params))
403 (num (or (cdr (assoc "x-part-number" params))
404 (if (consp entity-node-id)
407 (format "%s" (1+ num))))
408 (reverse entity-node-id) ".")
411 (let ((server (assoc "server" params)))
412 (setq access-type (cdr access-type))
414 (format "%s %s ([%s] %s)"
415 num subject access-type (cdr server))
416 (let ((site (cdr (assoc "site" params)))
417 (dir (cdr (assoc "directory" params)))
418 (url (cdr (assoc "url" params))))
420 (format "%s %s ([%s] %s)"
421 num subject access-type url)
422 (format "%s %s ([%s] %s:%s)"
423 num subject access-type site dir))))))
425 (let ((media-type (mime-entity-media-type entity))
426 (media-subtype (mime-entity-media-subtype entity))
427 (charset (cdr (assoc "charset" params)))
428 (encoding (mime-entity-encoding entity)))
432 (format " <%s/%s%s%s>"
433 media-type media-subtype
435 (concat "; " charset)
438 (concat " (" encoding ")")
440 (if (>= (+ (current-column)(length rest))(window-width))
443 (if body-is-invisible
446 (function mime-preview-play-current-entity))))
452 (defvar mime-header-presentation-method-alist nil
453 "Alist of major mode vs. corresponding header-presentation-method functions.
454 Each element looks like (SYMBOL . FUNCTION).
455 SYMBOL must be major mode in raw-buffer or t. t means default.
456 Interface of FUNCTION must be (ENTITY SITUATION).")
458 (defvar mime-view-ignored-field-list
459 '(".*Received:" ".*Path:" ".*Id:" "^References:"
460 "^Replied:" "^Errors-To:"
461 "^Lines:" "^Sender:" ".*Host:" "^Xref:"
462 "^Content-Type:" "^Precedence:"
463 "^Status:" "^X-VM-.*:")
464 "All fields that match this list will be hidden in MIME preview buffer.
465 Each elements are regexp of field-name.")
467 (defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:")
468 "All fields that match this list will be displayed in MIME preview buffer.
469 Each elements are regexp of field-name.")
475 ;;; @@@ predicate function
478 (in-calist-package 'mime-view)
480 (defun mime-calist::field-match-method-as-default-rule (calist
481 field-type field-value)
482 (let ((s-field (assq field-type calist)))
483 (cond ((null s-field)
484 (cons (cons field-type field-value) calist))
487 (define-calist-field-match-method
488 'header #'mime-calist::field-match-method-as-default-rule)
490 (define-calist-field-match-method
491 'body #'mime-calist::field-match-method-as-default-rule)
494 (defvar mime-preview-condition nil
495 "Condition-tree about how to display entity.")
497 ;;(ctree-set-calist-strictly
498 ;; 'mime-preview-condition '((type . application)(subtype . octet-stream)
500 ;; (body . visible)))
502 (ctree-set-calist-strictly
503 'mime-preview-condition '((type . application)(subtype . t)
506 (ctree-set-calist-strictly
507 'mime-preview-condition '((type . application)(subtype . t)
511 (ctree-set-calist-strictly
512 'mime-preview-condition '((type . application)(subtype . pgp)
515 (ctree-set-calist-strictly
516 'mime-preview-condition '((type . application)(subtype . x-latex)
519 (ctree-set-calist-strictly
520 'mime-preview-condition '((type . application)(subtype . x-selection)
523 (ctree-set-calist-strictly
524 'mime-preview-condition '((type . application)(subtype . x-comment)
527 (ctree-set-calist-strictly
528 'mime-preview-condition '((type . message)(subtype . delivery-status)
531 (ctree-set-calist-strictly
532 'mime-preview-condition
534 (body-presentation-method . mime-display-text/plain)))
536 (ctree-set-calist-strictly
537 'mime-preview-condition
540 (body-presentation-method . mime-display-text/plain)))
542 (ctree-set-calist-strictly
543 'mime-preview-condition
544 '((type . text)(subtype . enriched)
546 (body-presentation-method . mime-display-text/enriched)))
548 (ctree-set-calist-strictly
549 'mime-preview-condition
550 '((type . text)(subtype . richtext)
552 (body-presentation-method . mime-display-text/richtext)))
554 (ctree-set-calist-strictly
555 'mime-preview-condition
556 '((type . application)(subtype . x-postpet)
558 (body-presentation-method . mime-display-application/x-postpet)))
560 (ctree-set-calist-strictly
561 'mime-preview-condition '((type . application)(subtype . t)
564 (body-presentation-method . mime-display-detect-application/octet-stream)))
566 (ctree-set-calist-strictly
567 'mime-preview-condition
568 '((type . text)(subtype . t)
570 (body-presentation-method . mime-display-text/plain)))
572 (ctree-set-calist-strictly
573 'mime-preview-condition
574 '((type . text)(subtype . x-rot13-47-48)
576 (body-presentation-method . mime-display-text/x-rot13-47-48)))
578 (ctree-set-calist-strictly
579 'mime-preview-condition
580 '((type . multipart)(subtype . alternative)
582 (body-presentation-method . mime-display-multipart/alternative)))
584 (ctree-set-calist-strictly
585 'mime-preview-condition
586 '((type . multipart)(subtype . t)
588 (body-presentation-method . mime-display-multipart/mixed)))
590 (ctree-set-calist-strictly
591 'mime-preview-condition
592 '((type . message)(subtype . partial)
594 (body-presentation-method . mime-display-message/partial-button)))
596 (ctree-set-calist-strictly
597 'mime-preview-condition
598 '((type . message)(subtype . rfc822)
600 (body-presentation-method . mime-display-multipart/mixed)
601 (childrens-situation (header . visible)
602 (entity-button . invisible))))
604 (ctree-set-calist-strictly
605 'mime-preview-condition
606 '((type . message)(subtype . news)
608 (body-presentation-method . mime-display-multipart/mixed)
609 (childrens-situation (header . visible)
610 (entity-button . invisible))))
612 ;; message/external-body has only one child.
613 (ctree-set-calist-strictly
614 'mime-preview-condition
615 '((type . message)(subtype . external-body)
617 (body-presentation-method . nil)
618 (childrens-situation (header . invisible)
620 (entity-button . visible))))
623 ;;; @@@ entity presentation
626 (defun mime-display-text/plain (entity situation)
628 (narrow-to-region (point-max)(point-max))
629 (mime-insert-text-content entity)
630 (run-hooks 'mime-text-decode-hook)
631 (goto-char (point-max))
632 (if (not (eq (char-after (1- (point))) ?\n))
634 (mime-add-url-buttons)
635 (run-hooks 'mime-display-text/plain-hook)))
637 (defun mime-display-text (entity situation)
639 (narrow-to-region (point-max) (point-max))
641 (decode-coding-string
643 (if (fboundp 'mime-entity-body)
645 (mime-entity-body entity)
646 ;; #### This is wrong, but...
647 (mime-entity-content entity))
648 (or (cdr (assq 'encoding situation))
649 (if (fboundp 'mime-entity-body)
650 (mime-entity-encoding entity)
652 (or (cdr (assq 'coding situation))
655 (defun mime-display-text/richtext (entity situation)
657 (narrow-to-region (point-max)(point-max))
658 (mime-insert-text-content entity)
659 (run-hooks 'mime-text-decode-hook)
660 (let ((beg (point-min)))
661 (remove-text-properties beg (point-max) '(face nil))
662 (richtext-decode beg (point-max)))))
664 (defun mime-display-text/enriched (entity situation)
666 (narrow-to-region (point-max)(point-max))
667 (mime-insert-text-content entity)
668 (run-hooks 'mime-text-decode-hook)
669 (let ((beg (point-min)))
670 (remove-text-properties beg (point-max) '(face nil))
671 (enriched-decode beg (point-max)))))
673 (defun mime-display-text/x-rot13-47-48 (entity situation)
675 (narrow-to-region (point-max)(point-max))
676 (mime-insert-text-content entity)
677 (goto-char (point-max))
678 (if (not (eq (char-after (1- (point))) ?\n))
680 (mule-caesar-region (point-min) (point-max))
681 (mime-add-url-buttons)))
683 (put 'unpack 'lisp-indent-function 1)
684 (defmacro unpack (string &rest body)
685 `(let* ((*unpack*string* (string-as-unibyte ,string))
689 (defun unpack-skip (len)
690 (setq *unpack*index* (+ len *unpack*index*)))
692 (defun unpack-fixed (len)
694 (substring *unpack*string* *unpack*index* (+ *unpack*index* len))
697 (defun unpack-byte ()
698 (char-int (aref (unpack-fixed 1) 0)))
700 (defun unpack-short ()
701 (let* ((b0 (unpack-byte))
705 (defun unpack-long ()
706 (let* ((s0 (unpack-short))
708 (+ (* 65536 s0) s1)))
710 (defun unpack-string ()
711 (let ((len (unpack-byte)))
714 (defun unpack-string-sjis ()
715 (decode-mime-charset-string (unpack-string) 'shift_jis))
717 (defun postpet-decode (string)
722 (set-alist 'res 'carryingcount (unpack-long))
724 (set-alist 'res 'sentyear (unpack-short))
725 (set-alist 'res 'sentmonth (unpack-short))
726 (set-alist 'res 'sentday (unpack-short))
728 (set-alist 'res 'petname (unpack-string-sjis))
729 (set-alist 'res 'owner (unpack-string-sjis))
730 (set-alist 'res 'pettype (unpack-fixed 4))
731 (set-alist 'res 'health (unpack-short))
733 (set-alist 'res 'sex (unpack-long))
735 (set-alist 'res 'brain (unpack-byte))
737 (set-alist 'res 'happiness (unpack-byte))
739 (set-alist 'res 'petbirthyear (unpack-short))
740 (set-alist 'res 'petbirthmonth (unpack-short))
741 (set-alist 'res 'petbirthday (unpack-short))
743 (set-alist 'res 'from (unpack-string))
750 (set-alist 'res 'treasure (unpack-short))
751 (set-alist 'res 'money (unpack-long))
755 (defun mime-display-application/x-postpet (entity situation)
757 (narrow-to-region (point-max)(point-max))
758 (let ((pet (postpet-decode (mime-entity-content entity))))
760 (insert "Petname: " (cdr (assq 'petname pet)) "\n"
761 "Owner: " (cdr (assq 'owner pet)) "\n"
762 "Pettype: " (cdr (assq 'pettype pet)) "\n"
763 "From: " (cdr (assq 'from pet)) "\n"
764 "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n"
765 "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) "\n"
766 "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n"
767 "SentDay: " (int-to-string (cdr (assq 'sentday pet))) "\n"
768 "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n"
769 "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n"
770 "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n"
771 "Health: " (int-to-string (cdr (assq 'health pet))) "\n"
772 "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n"
773 "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n"
774 "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n"
775 "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n"
776 "Money: " (int-to-string (cdr (assq 'money pet))) "\n")
777 (insert "Invalid format\n"))
778 (run-hooks 'mime-display-application/x-postpet-hook))))
781 (defvar mime-view-announcement-for-message/partial
782 (if (and (>= emacs-major-version 19) window-system)
784 \[[ This is message/partial style split message. ]]
785 \[[ Please press `v' key in this buffer ]]
786 \[[ or click here by mouse button-2. ]]"
788 \[[ This is message/partial style split message. ]]
789 \[[ Please press `v' key in this buffer. ]]"))
791 (defun mime-display-message/partial-button (&optional entity situation)
793 (goto-char (point-max))
794 (if (not (search-backward "\n\n" nil t))
796 (goto-char (point-max))
797 (narrow-to-region (point-max)(point-max))
798 (insert mime-view-announcement-for-message/partial)
799 (mime-add-button (point-min)(point-max)
800 #'mime-preview-play-current-entity)))
802 (defun mime-display-multipart/mixed (entity situation)
803 (let ((children (mime-entity-children entity))
804 (original-major-mode-cell (assq 'major-mode situation))
806 (cdr (assq 'childrens-situation situation))))
807 (if original-major-mode-cell
808 (setq default-situation
809 (cons original-major-mode-cell default-situation)))
811 (mime-display-entity (car children) nil default-situation)
812 (setq children (cdr children)))))
814 (defun mime-display-multipart/alternative (entity situation)
815 (let* ((children (mime-entity-children entity))
816 (original-major-mode-cell (assq 'major-mode situation))
818 (cdr (assq 'childrens-situation situation)))
823 (if original-major-mode-cell
824 (setq default-situation
825 (cons original-major-mode-cell default-situation)))
830 (or (ctree-match-calist
831 mime-preview-condition
832 (append (mime-entity-situation child)
835 (if (cdr (assq 'body-presentation-method situation))
840 (cdr (assq 'type situation))
841 (cdr (assq 'subtype situation)))
842 mime-view-type-subtype-score-alist)
844 (cdr (assq 'type situation))
845 mime-view-type-subtype-score-alist)
848 mime-view-type-subtype-score-alist)))))
849 (if (> score max-score)
857 (let ((child (car children))
858 (situation (car situations)))
859 (mime-display-entity child (if (= i p)
861 (del-alist 'body-presentation-method
862 (copy-alist situation)))))
863 (setq children (cdr children)
864 situations (cdr situations)
867 (defun mime-display-detect-application/octet-stream (entity situation)
868 "Detect unknown ENTITY and display it inline.
869 This can only handle gzipped contents."
870 (or (and (mime-entity-filename entity)
871 (string-match "\\.gz$" (mime-entity-filename entity))
872 (mime-display-gzipped entity situation))
873 (mime-display-text/plain entity situation)))
875 (defun mime-display-gzipped (entity situation)
876 "Ungzip gzipped part and display."
878 (decode-coding-string
880 ;; #### Kludge to make FSF Emacs happy.
881 (if (featurep 'xemacs)
882 (insert (mime-entity-content entity))
883 (let ((content (mime-entity-content entity)))
884 (if (not (multibyte-string-p content))
885 ;; I really hate this brain-damaged function.
886 (set-buffer-multibyte nil))
889 (call-process-region (point-min) (point-max) "gzip" t t
892 (when (fboundp 'set-buffer-multibyte)
893 (set-buffer-multibyte t))
895 mime-view-automatic-conversion))
898 (defun mime-preview-inline ()
899 "View part as text without code conversion."
901 (let ((inhibit-read-only t)
902 (entity (get-text-property (point) 'mime-view-entity))
903 (situation (get-text-property (point) 'mime-view-situation))
906 (not (get-text-property (point) 'mime-view-entity-header))
907 (not (memq (mime-entity-media-type entity)
908 '(multipart message))))
909 (setq start (or (and (not (mime-entity-parent entity))
910 (1+ (previous-single-property-change
912 'mime-view-entity-header)))
913 (and (not (eq (point) (point-min)))
914 (not (eq (get-text-property (1- (point))
918 (previous-single-property-change (point)
923 (or (next-single-property-change (point)
927 (if (mime-view-entity-button-visible-p entity)
928 (mime-view-insert-entity-button entity))
929 (insert (mime-entity-content entity))
930 (if (and (bolp) (eolp))
933 (add-text-properties start (point)
934 (list 'mime-view-entity entity
935 'mime-view-situation situation))
938 (defun mime-preview-text (&optional ask-coding)
939 "View part as text. MIME charset will be guessed automatically.
940 With prefix, it prompts for coding-system."
942 (let ((inhibit-read-only t)
943 (mime-view-force-inline-types t)
944 (position (mime-preview-entity-boundary))
945 (coding (if ask-coding
946 (or (read-coding-system "Coding system: ")
947 mime-view-automatic-conversion)
948 mime-view-automatic-conversion))
950 (completing-read "Content Transfer Encoding: "
951 (mime-encoding-alist) nil t)))
953 (setq entity (get-text-property (car position) 'mime-view-entity)
954 situation (get-text-property (car position) 'mime-view-situation))
961 'body-presentation-method 'mime-display-text
962 (put-alist '*body 'visible situation)))))
964 (delete-region (car position) (cdr position))
965 (mime-display-entity entity situation))))
967 (defun mime-preview-type ()
968 "View part as text without code conversion."
970 (mime-preview-toggle-content t))
972 (defun mime-preview-buttonize ()
975 (goto-char (point-min))
977 (while (setq point (next-single-property-change
978 (point) 'mime-view-entity))
980 (unless (get-text-property (point) 'mime-button-callback)
981 (mime-preview-toggle-button))))))
983 (defun mime-preview-unbuttonize ()
986 (goto-char (point-min))
988 (while (setq point (next-single-property-change
989 (point) 'mime-view-entity))
991 (when (get-text-property (point) 'mime-button-callback)
992 (mime-preview-toggle-button))))))
995 ;;; @ acting-condition
998 (defvar mime-acting-condition nil
999 "Condition-tree about how to process entity.")
1001 (if (file-readable-p mailcap-file)
1002 (let ((entries (mailcap-parse-file)))
1004 (let ((entry (car entries))
1007 (let* ((field (car entry))
1008 (field-type (car field)))
1009 (cond ((eq field-type 'view) (setq view field))
1010 ((eq field-type 'print) (setq print field))
1011 ((memq field-type '(compose composetyped edit)))
1012 (t (setq shared (cons field shared)))))
1013 (setq entry (cdr entry)))
1014 (setq shared (nreverse shared))
1015 (ctree-set-calist-with-default
1016 'mime-acting-condition
1017 (append shared (list '(mode . "play")(cons 'method (cdr view)))))
1019 (ctree-set-calist-with-default
1020 'mime-acting-condition
1022 (list '(mode . "print")(cons 'method (cdr view)))))))
1023 (setq entries (cdr entries)))))
1025 (ctree-set-calist-strictly
1026 'mime-acting-condition
1027 '((type . application)(subtype . octet-stream)
1029 (method . mime-detect-content)))
1031 (ctree-set-calist-with-default
1032 'mime-acting-condition
1033 '((mode . "extract")
1034 (method . mime-save-content)))
1036 (ctree-set-calist-strictly
1037 'mime-acting-condition
1038 '((type . text)(subtype . x-rot13-47)(mode . "play")
1039 (method . mime-view-caesar)))
1040 (ctree-set-calist-strictly
1041 'mime-acting-condition
1042 '((type . text)(subtype . x-rot13-47-48)(mode . "play")
1043 (method . mime-view-caesar)))
1045 (ctree-set-calist-strictly
1046 'mime-acting-condition
1047 '((type . message)(subtype . rfc822)(mode . "play")
1048 (method . mime-view-message/rfc822)))
1049 (ctree-set-calist-strictly
1050 'mime-acting-condition
1051 '((type . message)(subtype . partial)(mode . "play")
1052 (method . mime-store-message/partial-piece)))
1054 (ctree-set-calist-strictly
1055 'mime-acting-condition
1056 '((type . message)(subtype . external-body)
1057 ("access-type" . "anon-ftp")
1058 (method . mime-view-message/external-anon-ftp)))
1060 (ctree-set-calist-strictly
1061 'mime-acting-condition
1062 '((type . message)(subtype . external-body)
1063 ("access-type" . "url")
1064 (method . mime-view-message/external-url)))
1066 (ctree-set-calist-strictly
1067 'mime-acting-condition
1068 '((type . application)(subtype . octet-stream)
1069 (method . mime-save-content)))
1072 ;;; @ quitting method
1075 (defvar mime-preview-quitting-method-alist
1076 '((mime-show-message-mode
1077 . mime-preview-quitting-method-for-mime-show-message-mode))
1078 "Alist of `major-mode' vs. quitting-method of mime-view.")
1080 (defvar mime-preview-over-to-previous-method-alist nil
1081 "Alist of `major-mode' vs. over-to-previous-method of mime-view.")
1083 (defvar mime-preview-over-to-next-method-alist nil
1084 "Alist of `major-mode' vs. over-to-next-method of mime-view.")
1087 ;;; @ following method
1090 (defvar mime-preview-following-method-alist nil
1091 "Alist of `major-mode' vs. following-method of mime-view.")
1093 (defvar mime-view-following-required-fields-list
1100 (defun mime-display-entity (entity &optional situation
1101 default-situation preview-buffer)
1102 "Display mime-entity ENTITY."
1104 (setq preview-buffer (current-buffer)))
1105 (in-calist-package 'mime-view)
1108 (or (ctree-match-calist mime-preview-condition
1109 (append (mime-entity-situation entity)
1111 default-situation)))
1112 (let ((button-is-visible (mime-view-button-is-visible situation))
1114 (mime-view-header-is-visible situation))
1115 (header-presentation-method
1116 (or (cdr (assq '*header-presentation-method situation))
1117 (cdr (assq 'header-presentation-method situation))
1118 (cdr (assq (cdr (assq 'major-mode situation))
1119 mime-header-presentation-method-alist))))
1121 (mime-view-body-is-visible situation))
1122 (body-presentation-method
1123 (cdr (assq 'body-presentation-method situation)))
1124 (children (mime-entity-children entity))
1126 ;; Check if attachment is specified.
1127 ;; if inline is forced or not.
1128 (unless (or (eq t mime-view-force-inline-types)
1129 (memq (mime-entity-media-type entity)
1130 mime-view-force-inline-types)
1131 (memq (mime-view-entity-type/subtype entity)
1132 mime-view-force-inline-types)
1133 ;; whether Content-Disposition header exists.
1134 (not (mime-entity-content-disposition entity))
1136 (mime-content-disposition-type
1137 (mime-entity-content-disposition entity))))
1138 ;; This is attachment.
1139 ;; But show header when this is root entity.
1140 (if (mime-root-entity-p entity)
1141 (progn (setq body-is-visible nil)
1142 (put-alist 'body 'invisible situation))
1143 (setq header-is-visible nil)
1144 (put-alist 'header 'invisible situation)))
1145 (set-buffer preview-buffer)
1148 (narrow-to-region nb nb)
1149 (if button-is-visible
1150 (mime-view-insert-entity-button entity
1151 ;; work around composite type
1154 (when header-is-visible
1156 (if header-presentation-method
1157 (funcall header-presentation-method entity situation)
1158 (mime-insert-header entity
1159 mime-view-ignored-field-list
1160 mime-view-visible-field-list))
1161 (run-hooks 'mime-display-header-hook)
1162 (put-text-property nhb (point-max) 'mime-view-entity-header entity)
1163 (goto-char (point-max))
1167 ((and body-is-visible
1168 (functionp body-presentation-method))
1169 (funcall body-presentation-method entity situation))
1171 ;; When both body and button is not displayed,
1172 ;; there should be a button to indicate there's a part.
1173 (unless button-is-visible
1174 (goto-char (point-max))
1175 (mime-view-insert-entity-button entity
1176 ;; work around composite type
1179 (unless header-is-visible
1180 (goto-char (point-max))
1182 (setq ne (point-max)))
1183 (put-text-property nb ne 'mime-view-entity entity)
1184 (put-text-property nb ne 'mime-view-situation situation)
1185 (put-text-property nbb ne 'mime-view-entity-body entity)
1187 (if (and children body-is-visible)
1188 (if (functionp body-presentation-method)
1189 (funcall body-presentation-method entity situation)
1190 (mime-display-multipart/mixed entity situation)))))
1192 ;;; @ MIME viewer mode
1195 (defconst mime-view-menu-title "MIME-View")
1196 (defconst mime-view-menu-list
1197 '((up "Move to upper entity" mime-preview-move-to-upper)
1198 (previous "Move to previous entity" mime-preview-move-to-previous)
1199 (next "Move to next entity" mime-preview-move-to-next)
1200 (scroll-down "Scroll-down" mime-preview-scroll-down-entity)
1201 (scroll-up "Scroll-up" mime-preview-scroll-up-entity)
1202 (play "Play current entity" mime-preview-play-current-entity)
1203 (extract "Extract current entity" mime-preview-extract-current-entity)
1204 (print "Print current entity" mime-preview-print-current-entity)
1205 (raw "View text without code conversion" mime-preview-inline)
1206 (text "View text with code conversion" mime-preview-text)
1207 (type "View internally as type" mime-preview-type))
1208 "Menu for MIME Viewer.")
1210 (cond ((featurep 'xemacs)
1211 (defvar mime-view-xemacs-popup-menu
1212 (cons mime-view-menu-title
1215 (vector (nth 1 item)(nth 2 item) t)))
1216 mime-view-menu-list)))
1217 (defun mime-view-xemacs-popup-menu (event)
1218 "Popup the menu in the MIME Viewer buffer"
1220 (select-window (event-window event))
1221 (set-buffer (event-buffer event))
1222 (popup-menu 'mime-view-xemacs-popup-menu))
1223 (defvar mouse-button-2 'button2))
1225 (defvar mouse-button-2 [mouse-2])))
1227 (defun mime-view-define-keymap (&optional default)
1228 (let ((mime-view-mode-map (if (keymapp default)
1229 (copy-keymap default)
1230 (make-sparse-keymap))))
1231 (define-key mime-view-mode-map
1232 "u" (function mime-preview-move-to-upper))
1233 (define-key mime-view-mode-map
1234 "p" (function mime-preview-move-to-previous))
1235 (define-key mime-view-mode-map
1236 "n" (function mime-preview-move-to-next))
1237 (define-key mime-view-mode-map
1238 "\e\t" (function mime-preview-move-to-previous))
1239 (define-key mime-view-mode-map
1240 "\t" (function mime-preview-move-to-next))
1241 (define-key mime-view-mode-map
1242 " " (function mime-preview-scroll-up-entity))
1243 (define-key mime-view-mode-map
1244 "\M- " (function mime-preview-scroll-down-entity))
1245 (define-key mime-view-mode-map
1246 "\177" (function mime-preview-scroll-down-entity))
1247 (define-key mime-view-mode-map
1248 "\C-m" (function mime-preview-next-line-entity))
1249 (define-key mime-view-mode-map
1250 "\C-\M-m" (function mime-preview-previous-line-entity))
1251 (define-key mime-view-mode-map
1252 "v" (function mime-preview-play-current-entity))
1253 (define-key mime-view-mode-map
1254 "e" (function mime-preview-extract-current-entity))
1255 (define-key mime-view-mode-map
1256 "\C-c\C-e" (function mime-preview-extract-current-entity))
1257 (define-key mime-view-mode-map
1258 "i" (function mime-preview-inline))
1259 (define-key mime-view-mode-map
1260 "c" (function mime-preview-text))
1261 (define-key mime-view-mode-map
1262 "t" (function mime-preview-type))
1263 (define-key mime-view-mode-map
1264 "b" (function mime-preview-buttonize))
1265 (define-key mime-view-mode-map
1266 "B" (function mime-preview-unbuttonize))
1267 (define-key mime-view-mode-map
1268 "\C-c\C-t\C-h" (function mime-preview-toggle-header))
1269 (define-key mime-view-mode-map
1270 "\C-c\C-th" (function mime-preview-toggle-header))
1271 (define-key mime-view-mode-map
1272 "\C-c\C-t\C-c" (function mime-preview-toggle-content))
1273 (define-key mime-view-mode-map
1274 "\C-c\C-tc" (function mime-preview-toggle-content))
1275 (define-key mime-view-mode-map
1276 "\C-c\C-tH" (function mime-preview-toggle-all-header))
1277 (define-key mime-view-mode-map
1278 "\C-c\C-tb" (function mime-preview-toggle-button))
1279 (define-key mime-view-mode-map
1280 "\C-c\C-p" (function mime-preview-print-current-entity))
1281 (define-key mime-view-mode-map
1282 "a" (function mime-preview-follow-current-entity))
1283 (define-key mime-view-mode-map
1284 "q" (function mime-preview-quit))
1285 (define-key mime-view-mode-map
1286 "\C-c\C-x" (function mime-preview-kill-buffer))
1287 ;; (define-key mime-view-mode-map
1288 ;; "<" (function beginning-of-buffer))
1289 ;; (define-key mime-view-mode-map
1290 ;; ">" (function end-of-buffer))
1291 (define-key mime-view-mode-map
1292 "?" (function describe-mode))
1293 (define-key mime-view-mode-map
1294 [tab] (function mime-preview-move-to-next))
1295 (define-key mime-view-mode-map
1296 [delete] (function mime-preview-scroll-down-entity))
1297 (define-key mime-view-mode-map
1298 [backspace] (function mime-preview-scroll-down-entity))
1299 (if (functionp default)
1300 (cond ((featurep 'xemacs)
1301 (set-keymap-default-binding mime-view-mode-map default))
1303 (setq mime-view-mode-map
1304 (append mime-view-mode-map (list (cons t default)))))))
1306 (define-key mime-view-mode-map
1307 mouse-button-2 (function mime-button-dispatcher)))
1308 (cond ((featurep 'xemacs)
1309 (define-key mime-view-mode-map
1310 mouse-button-3 (function mime-view-xemacs-popup-menu)))
1311 ((>= emacs-major-version 19)
1312 (define-key mime-view-mode-map [menu-bar mime-view]
1313 (cons mime-view-menu-title
1314 (make-sparse-keymap mime-view-menu-title)))
1317 (define-key mime-view-mode-map
1318 (vector 'menu-bar 'mime-view (car item))
1319 (cons (nth 1 item)(nth 2 item)))))
1320 (reverse mime-view-menu-list))))
1321 (use-local-map mime-view-mode-map)
1322 (run-hooks 'mime-view-define-keymap-hook)))
1324 (defsubst mime-maybe-hide-echo-buffer ()
1325 "Clear mime-echo buffer and delete window for it."
1326 (let ((buf (get-buffer mime-echo-buffer-name)))
1331 (let ((win (get-buffer-window buf)))
1333 (delete-window win)))
1334 (bury-buffer buf)))))
1336 (defvar mime-view-redisplay nil)
1339 (defun mime-display-message (message &optional preview-buffer
1340 mother default-keymap-or-function
1341 original-major-mode)
1342 "View MESSAGE in MIME-View mode.
1344 Optional argument PREVIEW-BUFFER specifies the buffer of the
1345 presentation. It must be either nil or a name of preview buffer.
1347 Optional argument MOTHER specifies mother-buffer of the preview-buffer.
1349 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1350 function. If it is a keymap, keymap of MIME-View mode will be added
1351 to it. If it is a function, it will be bound as default binding of
1352 keymap of MIME-View mode."
1353 (mime-maybe-hide-echo-buffer)
1354 (let ((win-conf (current-window-configuration)))
1356 (setq preview-buffer
1357 (concat "*Preview-" (mime-entity-name message) "*")))
1358 (or original-major-mode
1359 (setq original-major-mode major-mode))
1360 (let ((inhibit-read-only t))
1361 (set-buffer (get-buffer-create preview-buffer))
1365 (setq mime-mother-buffer mother))
1366 (setq mime-preview-original-window-configuration win-conf)
1367 (setq major-mode 'mime-view-mode)
1368 (setq mode-name "MIME-View")
1369 (mime-display-entity message nil
1370 (list (cons 'entity-button 'invisible)
1371 (cons 'header 'visible)
1372 (cons 'major-mode original-major-mode))
1374 (mime-view-define-keymap default-keymap-or-function)
1375 (set (make-local-variable 'line-move-ignore-invisible) t)
1377 (next-single-property-change (point-min) 'mime-view-entity)))
1380 (goto-char (point-min))
1381 (search-forward "\n\n" nil t)))
1382 (run-hooks 'mime-view-mode-hook)
1383 (set-buffer-modified-p nil)
1384 (setq buffer-read-only t)
1388 (defun mime-view-buffer (&optional raw-buffer preview-buffer mother
1389 default-keymap-or-function
1390 representation-type)
1391 "View RAW-BUFFER in MIME-View mode.
1392 Optional argument PREVIEW-BUFFER is either nil or a name of preview
1394 Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or
1395 function. If it is a keymap, keymap of MIME-View mode will be added
1396 to it. If it is a function, it will be bound as default binding of
1397 keymap of MIME-View mode.
1398 Optional argument REPRESENTATION-TYPE is representation-type of
1399 message. It must be nil, `binary' or `cooked'. If it is nil,
1400 `cooked' is used as default."
1403 (setq raw-buffer (current-buffer)))
1404 (or representation-type
1405 (setq representation-type
1407 (set-buffer raw-buffer)
1408 (cdr (or (assq major-mode mime-raw-representation-type-alist)
1409 (assq t mime-raw-representation-type-alist))))))
1410 (if (eq representation-type 'binary)
1411 (setq representation-type 'buffer))
1412 (setq preview-buffer (mime-display-message
1413 (mime-open-entity representation-type raw-buffer)
1414 preview-buffer mother default-keymap-or-function))
1415 (or (get-buffer-window preview-buffer)
1416 (let ((r-win (get-buffer-window raw-buffer)))
1418 (set-window-buffer r-win preview-buffer)
1419 (let ((m-win (and mother (get-buffer-window mother))))
1421 (set-window-buffer m-win preview-buffer)
1422 (switch-to-buffer preview-buffer)))))))
1424 (defun mime-view-mode (&optional mother ctl encoding
1425 raw-buffer preview-buffer
1426 default-keymap-or-function)
1427 "Major mode for viewing MIME message.
1429 Here is a list of the standard keys for mime-view-mode.
1434 u Move to upper content
1435 p or M-TAB Move to previous content
1436 n or TAB Move to next content
1437 SPC Scroll up or move to next content
1438 M-SPC or DEL Scroll down or move to previous content
1439 RET Move to next line
1440 M-RET Move to previous line
1441 v Decode current content as `play mode'
1442 e Decode current content as `extract mode'
1443 C-c C-p Decode current content as `print mode'
1444 a Followup to current content.
1446 button-2 Move to point under the mouse cursor
1447 and decode current content as `play mode'"
1449 (unless mime-view-redisplay
1451 (if raw-buffer (set-buffer raw-buffer))
1454 (or (assq major-mode mime-raw-representation-type-alist)
1455 (assq t mime-raw-representation-type-alist)))))
1456 (if (eq type 'binary)
1457 (setq type 'buffer))
1458 (setq mime-message-structure (mime-open-entity type raw-buffer))
1459 (or (mime-entity-content-type mime-message-structure)
1460 (mime-entity-set-content-type-internal
1461 mime-message-structure ctl)))
1462 (or (mime-entity-encoding mime-message-structure)
1463 (mime-entity-set-encoding-internal mime-message-structure encoding))))
1464 (mime-display-message mime-message-structure preview-buffer
1465 mother default-keymap-or-function))
1471 (autoload 'mime-preview-play-current-entity "mime-play"
1472 "Play current entity." t)
1474 (defun mime-preview-extract-current-entity (&optional ignore-examples)
1475 "Extract current entity into file (maybe).
1476 It decodes current entity to call internal or external method as
1477 \"extract\" mode. The method is selected from variable
1478 `mime-acting-condition'."
1480 (mime-preview-play-current-entity ignore-examples "extract"))
1482 (defun mime-preview-print-current-entity (&optional ignore-examples)
1483 "Print current entity (maybe).
1484 It decodes current entity to call internal or external method as
1485 \"print\" mode. The method is selected from variable
1486 `mime-acting-condition'."
1488 (mime-preview-play-current-entity ignore-examples "print"))
1494 (defun mime-preview-follow-current-entity ()
1495 "Write follow message to current entity.
1496 It calls following-method selected from variable
1497 `mime-preview-following-method-alist'."
1499 (let (entity position entity-node-id header-exists)
1500 (while (null (setq entity
1501 (get-text-property (point) 'mime-view-entity)))
1503 (setq position (mime-preview-entity-boundary))
1504 (setq entity-node-id (mime-entity-node-id entity)
1506 ;; When on an invisible entity, there's no header.
1507 (or (mime-view-header-is-visible
1508 (get-text-property (car position) 'mime-view-situation))
1509 ;; We are on a rfc822 button.
1510 (and (eq 'message (mime-entity-media-type
1512 (eq 'rfc822 (mime-entity-media-subtype
1515 (next-single-property-change
1516 (car position) 'mime-button-callback
1518 'mime-view-entity-header))))
1519 (let* ((mode (mime-preview-original-major-mode 'recursive))
1521 (format "%s-%s" (buffer-name) (reverse entity-node-id)))
1523 (the-buf (current-buffer))
1526 (set-buffer (setq new-buf (get-buffer-create new-name)))
1528 ;; Compatibility kludge.
1529 ;; FSF Emacs can only take substring of current-buffer.
1532 (set-buffer the-buf)
1533 (buffer-substring-no-properties (car position)
1536 (delete-region (goto-char (point-min))
1537 (re-search-forward "^$"))
1538 (goto-char (point-min))
1540 (goto-char (point-min))
1541 (let ((current-entity
1542 (if (and (eq (mime-entity-media-type entity) 'message)
1543 (eq (mime-entity-media-subtype entity) 'rfc822))
1544 (car (mime-entity-children entity))
1546 (while (and current-entity
1547 (if (and (eq (mime-entity-media-type
1548 current-entity) 'message)
1549 (eq (mime-entity-media-subtype
1550 current-entity) 'rfc822))
1552 (mime-insert-header current-entity fields)
1554 (setq fields (std11-collect-field-names)
1555 current-entity (mime-entity-parent current-entity))))
1556 (let ((rest mime-view-following-required-fields-list)
1559 (setq field-name (car rest))
1560 (or (std11-field-body field-name)
1563 (set-buffer the-buf)
1564 (let ((entity (when mime-mother-buffer
1565 (set-buffer mime-mother-buffer)
1566 (get-text-property (point)
1567 'mime-view-entity))))
1569 (null (setq ret (mime-entity-fetch-field
1570 entity field-name))))
1571 (setq entity (mime-entity-parent entity)))))
1573 (insert (concat field-name ": " ret "\n")))))
1574 (setq rest (cdr rest))))
1575 (mime-decode-header-in-buffer))
1576 (let ((f (cdr (assq mode mime-preview-following-method-alist))))
1581 "Sorry, following method for %s is not implemented yet."
1588 (defun mime-preview-move-to-upper ()
1589 "Move to upper entity.
1590 If there is no upper entity, call function `mime-preview-quit'."
1593 (while (null (setq cinfo
1594 (get-text-property (point) 'mime-view-entity)))
1596 (let ((r (mime-entity-parent cinfo))
1599 (while (setq point (previous-single-property-change
1600 (point) 'mime-view-entity))
1602 (when (eq r (get-text-property (point) 'mime-view-entity))
1603 (if (or (eq mime-preview-move-scroll t)
1604 (and mime-preview-move-scroll
1607 (move-to-window-line -1)
1608 (forward-line (* -1 next-screen-context-lines))
1611 (recenter next-screen-context-lines))
1613 (mime-preview-quit)))))
1615 (defun mime-preview-move-to-previous ()
1616 "Move to previous entity.
1617 If there is no previous entity, it calls function registered in
1618 variable `mime-preview-over-to-previous-method-alist'."
1620 (while (and (not (bobp))
1621 (null (get-text-property (point) 'mime-view-entity)))
1623 (let ((point (previous-single-property-change (point) 'mime-view-entity)))
1625 (>= point (point-min)))
1626 (if (get-text-property (1- point) 'mime-view-entity)
1627 (progn (goto-char point)
1629 (or (eq mime-preview-move-scroll t)
1630 (and mime-preview-move-scroll
1633 (move-to-window-line 0)
1634 (forward-line next-screen-context-lines)
1637 (recenter next-screen-context-lines)))
1638 (goto-char (1- point))
1639 (mime-preview-move-to-previous))
1640 (let ((f (assq (mime-preview-original-major-mode)
1641 mime-preview-over-to-previous-method-alist)))
1643 (funcall (cdr f)))))))
1645 (defun mime-preview-move-to-next ()
1646 "Move to next entity.
1647 If there is no previous entity, it calls function registered in
1648 variable `mime-preview-over-to-next-method-alist'."
1650 (while (and (not (eobp))
1651 (null (get-text-property (point) 'mime-view-entity)))
1653 (let ((point (next-single-property-change (point) 'mime-view-entity)))
1655 (<= point (point-max)))
1658 (if (null (get-text-property point 'mime-view-entity))
1659 (mime-preview-move-to-next)
1661 (or (eq mime-preview-move-scroll t)
1662 (and mime-preview-move-scroll
1665 (move-to-window-line -1)
1667 (* -1 next-screen-context-lines))
1670 (recenter next-screen-context-lines))))
1671 (let ((f (assq (mime-preview-original-major-mode)
1672 mime-preview-over-to-next-method-alist)))
1674 (funcall (cdr f)))))))
1676 (defun mime-preview-scroll-up-entity (&optional h)
1677 "Scroll up current entity.
1678 If reached to (point-max), it calls function registered in variable
1679 `mime-preview-over-to-next-method-alist'."
1682 (let ((f (assq (mime-preview-original-major-mode)
1683 mime-preview-over-to-next-method-alist)))
1687 (or (next-single-property-change (point) 'mime-view-entity)
1689 (bottom (window-end (selected-window))))
1692 (not mime-preview-scroll-full-screen))
1693 (progn (goto-char point)
1694 (recenter next-screen-context-lines))
1698 (goto-char (point-max))))))))
1700 (defun mime-preview-scroll-down-entity (&optional h)
1701 "Scroll down current entity.
1702 If reached to (point-min), it calls function registered in variable
1703 `mime-preview-over-to-previous-method-alist'."
1706 (let ((f (assq (mime-preview-original-major-mode)
1707 mime-preview-over-to-previous-method-alist)))
1711 (or (previous-single-property-change (point) 'mime-view-entity)
1713 (top (window-start (selected-window))))
1716 (not mime-preview-scroll-full-screen))
1717 (progn (goto-char point)
1718 (recenter (* -1 next-screen-context-lines)))
1721 (beginning-of-buffer
1722 (goto-char (point-min))))))))
1724 (defun mime-preview-next-line-entity (&optional lines)
1725 "Scroll up one line (or prefix LINES lines).
1726 If LINES is negative, scroll down LINES lines."
1728 (mime-preview-scroll-up-entity (or lines 1)))
1730 (defun mime-preview-previous-line-entity (&optional lines)
1731 "Scrroll down one line (or prefix LINES lines).
1732 If LINES is negative, scroll up LINES lines."
1734 (mime-preview-scroll-down-entity (or lines 1)))
1736 (defun mime-preview-entity-boundary (&optional point)
1738 (setq point (point)))
1739 (and (eq point (point-max))
1740 (setq point (1- (point-max))))
1741 (let ((entity (get-text-property point 'mime-view-entity))
1742 (start (previous-single-property-change (1+ point) 'mime-view-entity
1745 (if (not (mime-entity-node-id entity))
1746 (setq end (point-max))
1747 (while (and (mime-entity-children entity)
1749 (if (not (mime-view-body-is-visible
1750 (get-text-property point 'mime-view-situation)))
1752 ;; If the part is shown, search the last part.
1753 (let* ((child (car (last (mime-entity-children entity))))
1754 (node-id (mime-entity-node-id child))
1755 (tmp-node-id (mime-entity-node-id
1756 (get-text-property point
1757 'mime-view-entity))))
1758 (while (or (< (length tmp-node-id)
1760 (not (eq (nthcdr (- (length tmp-node-id)
1765 (next-single-property-change point 'mime-view-entity)
1766 tmp-node-id (mime-entity-node-id
1767 (get-text-property point
1768 'mime-view-entity))))
1769 (setq entity child))))
1770 (setq end (next-single-property-change
1771 point 'mime-view-entity nil (point-max))))
1774 (defun mime-preview-toggle-header (&optional show)
1775 "Toggle display of entity header.
1776 When prefix is given, it always displays the header."
1778 (let ((inhibit-read-only t)
1779 (mime-view-force-inline-types t)
1780 (position (mime-preview-entity-boundary))
1781 entity header-is-visible situation)
1782 (setq entity (get-text-property (car position) 'mime-view-entity)
1783 situation (get-text-property (car position) 'mime-view-situation))
1784 (setq header-is-visible (mime-view-header-is-visible situation))
1786 (delete-region (car position) (cdr position))
1787 (if (or show (not header-is-visible))
1788 (mime-display-entity
1790 (del-alist '*entity-button
1791 (put-alist '*header 'visible
1793 (mime-display-entity
1795 (put-alist '*entity-button
1797 (put-alist '*header 'invisible
1800 (defun mime-preview-toggle-all-header (&optional show)
1801 "Toggle display of entity header.
1802 When prefix is given, it always displays the header."
1804 (let ((inhibit-read-only t)
1805 (mime-view-force-inline-types t)
1806 (position (mime-preview-entity-boundary))
1807 entity header-is-visible situation)
1808 (setq entity (get-text-property (car position) 'mime-view-entity)
1809 situation (get-text-property (car position) 'mime-view-situation))
1810 (setq header-is-visible (mime-view-header-is-visible situation))
1812 (delete-region (car position) (cdr position))
1813 (if (or show (not header-is-visible))
1814 (mime-display-entity
1816 (del-alist '*entity-button
1818 (del-alist '*header-presentation-method
1820 (mime-display-entity
1827 (put-alist '*header-presentation-method
1828 #'(lambda (entity situation)
1830 entity nil '(".*")))
1833 (defun mime-preview-toggle-content (&optional show)
1834 "Toggle display of entity body.
1835 When prefix is given, it always displays the content."
1837 (let ((inhibit-read-only t)
1838 (mime-view-force-inline-types t)
1839 (position (mime-preview-entity-boundary))
1841 (setq entity (get-text-property (car position) 'mime-view-entity)
1842 situation (get-text-property (car position) 'mime-view-situation))
1844 (if (or show (not (mime-view-body-is-visible situation)))
1847 (put-alist '*body 'visible situation))
1849 '*entity-button 'visible
1850 (put-alist '*body 'invisible situation))))
1852 (delete-region (car position) (cdr position))
1853 (mime-display-entity entity situation))))
1855 (defun mime-preview-toggle-button (&optional show)
1856 "Toggle display of entity button.
1857 When prefix is given, it always displays the content."
1859 (let ((inhibit-read-only t)
1860 (mime-view-force-inline-types t)
1861 (position (mime-preview-entity-boundary))
1862 entity situation button-is-visible)
1863 (setq entity (get-text-property (car position) 'mime-view-entity)
1864 situation (get-text-property (car position) 'mime-view-situation)
1865 button-is-visible (mime-view-button-is-visible situation))
1867 (delete-region (car position) (cdr position))
1868 (if (or show (not button-is-visible))
1869 (mime-display-entity entity
1870 (put-alist '*entity-button
1871 'visible situation))
1872 (mime-display-entity entity
1873 (put-alist '*entity-button
1874 'invisible situation))))))
1879 (defun mime-preview-quit ()
1880 "Quit from MIME-preview buffer.
1881 It calls function registered in variable
1882 `mime-preview-quitting-method-alist'."
1884 (let ((r (assq (mime-preview-original-major-mode)
1885 mime-preview-quitting-method-alist)))
1888 (kill-buffer (current-buffer)))))
1890 (defun mime-preview-kill-buffer ()
1892 (kill-buffer (current-buffer)))
1898 (provide 'mime-view)
1900 (run-hooks 'mime-view-load-hook)
1902 ;;; mime-view.el ends here