X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=852e15d230d9167599518522c0bb7f9884bfd7e9;hb=0d58dc2ad4a6baec5ebb28280a57664da82ab5aa;hp=a47be9ae17b1b7ab135359d4c038a81c852f5534;hpb=fa8879a59f91932d16bc454aec130359296460b8;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index a47be9a..852e15d 100644 --- a/mime-view.el +++ b/mime-view.el @@ -3,8 +3,8 @@ ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Created: 1994/7/13 -;; Renamed: 1994/8/31 from tm-body.el +;; Created: 1994/07/13 +;; Renamed: 1994/08/31 from tm-body.el ;; Renamed: 1997/02/19 from tm-view.el ;; Keywords: MIME, multimedia, mail, news @@ -31,52 +31,138 @@ (require 'mel) (require 'eword-decode) (require 'mime-parse) -(require 'mime-text) +(require 'semi-def) (require 'calist) +(require 'alist) +(require 'mailcap) ;;; @ version ;;; (defconst mime-view-version-string - `,(concat "SEMI MIME-View " - (mapconcat #'number-to-string (cdr semi-version) ".") - " (" (car semi-version) ")")) + `,(concat (car mime-module-version) " MIME-View " + (mapconcat #'number-to-string (cddr mime-module-version) ".") + " (" (cadr mime-module-version) ")")) -;;; @ buffer local variables +;;; @ variables ;;; -;;; @@ in raw-buffer +(defgroup mime-view nil + "MIME view mode" + :group 'mime) + +(defcustom mime-view-find-every-acting-situation t + "*Find every available acting-situation if non-nil." + :group 'mime-view + :type 'boolean) + +(defcustom mime-acting-situation-examples-file "~/.mime-example" + "*File name of example about acting-situation demonstrated by user." + :group 'mime-view + :type 'file) + + +;;; @ in raw-buffer (representation space) ;;; -(defvar mime-raw-message-info +(defvar mime-raw-message-info nil "Information about structure of message. Please use reference function `mime-entity-SLOT' to get value of SLOT. Following is a list of slots of the structure: -node-id reversed entity-number (list of integers) -point-min beginning point of region in raw-buffer -point-max end point of region in raw-buffer -type media-type (symbol) -subtype media-subtype (symbol) -type/subtype media-type/subtype (string or nil) -parameters parameter of Content-Type field (association list) -encoding Content-Transfer-Encoding (string or nil) -children entities included in this entity (list of content-infos) +buffer buffer includes this entity (buffer). +node-id node-id (list of integers) +header-start minimum point of header in raw-buffer +header-end maximum point of header in raw-buffer +body-start minimum point of body in raw-buffer +body-end maximum point of body in raw-buffer +content-type content-type (content-type) +content-disposition content-disposition (content-disposition) +encoding Content-Transfer-Encoding (string or nil) +children entities included in this entity (list of entity) If an entity includes other entities in its body, such as multipart or message/rfc822, `mime-entity' structures of them are included in `children', so the `mime-entity' structure become a tree.") (make-variable-buffer-local 'mime-raw-message-info) + (defvar mime-preview-buffer nil "MIME-preview buffer corresponding with the (raw) buffer.") (make-variable-buffer-local 'mime-preview-buffer) -;;; @@ in preview-buffer +(defvar mime-raw-representation-type nil + "Representation-type of mime-raw-buffer. +It must be nil, `binary' or `cooked'. +If it is nil, `mime-raw-representation-type-alist' is used as default +value. +Notice that this variable is usually used as buffer local variable in +raw-buffer.") + +(make-variable-buffer-local 'mime-raw-representation-type) + +(defvar mime-raw-representation-type-alist + '((mime-show-message-mode . binary) + (mime-temp-message-mode . binary) + (t . cooked) + ) + "Alist of major-mode vs. representation-type of mime-raw-buffer. +Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is +major-mode or t. t means default. REPRESENTATION-TYPE must be +`binary' or `cooked'. +This value is overridden by buffer local variable +`mime-raw-representation-type' if it is not nil.") + + +(defsubst mime-raw-find-entity-from-node-id (entity-node-id + &optional message-info) + "Return entity from ENTITY-NODE-ID in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (mime-raw-find-entity-from-number (reverse entity-node-id) message-info)) + +(defun mime-raw-find-entity-from-number (entity-number &optional message-info) + "Return entity from ENTITY-NUMBER in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (or message-info + (setq message-info mime-raw-message-info)) + (if (eq entity-number t) + message-info + (let ((sn (car entity-number))) + (if (null sn) + message-info + (let ((rc (nth sn (mime-entity-children message-info)))) + (if rc + (mime-raw-find-entity-from-number (cdr entity-number) rc) + )) + )))) + +(defun mime-raw-find-entity-from-point (point &optional message-info) + "Return entity from POINT in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (or message-info + (setq message-info mime-raw-message-info)) + (if (and (<= (mime-entity-point-min message-info) point) + (<= point (mime-entity-point-max message-info))) + (let ((children (mime-entity-children message-info))) + (catch 'tag + (while children + (let ((ret + (mime-raw-find-entity-from-point point (car children)))) + (if ret + (throw 'tag ret) + )) + (setq children (cdr children))) + message-info)))) + + +;;; @ in preview-buffer (presentation space) ;;; (defvar mime-mother-buffer nil @@ -89,20 +175,160 @@ message/partial, it is called `mother-buffer'.") "Raw buffer corresponding with the (MIME-preview) buffer.") (make-variable-buffer-local 'mime-raw-buffer) -(defvar mime-preview-original-major-mode nil - "Major-mode of mime-raw-buffer.") -(make-variable-buffer-local 'mime-preview-original-major-mode) - +(defvar mime-preview-original-window-configuration nil + "Window-configuration before mime-view-mode is called.") (make-variable-buffer-local 'mime-preview-original-window-configuration) +(defun mime-preview-original-major-mode (&optional recursive) + "Return major-mode of original buffer. +If optional argument RECURSIVE is non-nil and current buffer has +mime-mother-buffer, it returns original major-mode of the +mother-buffer." + (if (and recursive mime-mother-buffer) + (save-excursion + (set-buffer mime-mother-buffer) + (mime-preview-original-major-mode recursive) + ) + (save-excursion + (set-buffer + (mime-entity-buffer + (get-text-property (point-min) 'mime-view-entity))) + major-mode))) + + +;;; @ entity information +;;; + +(defsubst mime-entity-parent (entity &optional message-info) + "Return mother entity of ENTITY. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' in buffer of ENTITY is used." + (mime-raw-find-entity-from-node-id + (cdr (mime-entity-node-id entity)) + (or message-info + (save-excursion + (set-buffer (mime-entity-buffer entity)) + mime-raw-message-info)))) + +(defun mime-entity-situation (entity) + "Return situation of ENTITY." + (append (or (mime-entity-content-type entity) + (make-mime-content-type 'text 'plain)) + (let ((d (mime-entity-content-disposition entity))) + (cons (cons 'disposition-type + (mime-content-disposition-type d)) + (mapcar (function + (lambda (param) + (let ((name (car param))) + (cons (cond ((string= name "filename") + 'filename) + ((string= name "creation-date") + 'creation-date) + ((string= name "modification-date") + 'modification-date) + ((string= name "read-date") + 'read-date) + ((string= name "size") + 'size) + (t (cons 'disposition (car param)))) + (cdr param))))) + (mime-content-disposition-parameters d)) + )) + (list (cons 'encoding (mime-entity-encoding entity)) + (cons 'major-mode + (save-excursion + (set-buffer (mime-entity-buffer entity)) + major-mode))) + )) + + +(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode")) + +(defun mime-raw-get-uu-filename () + (save-excursion + (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0)(match-end 0)) + )))) + +(defun mime-raw-get-subject (entity) + (or (std11-find-field-body '("Content-Description" "Subject")) + (let ((ret (mime-entity-content-disposition entity))) + (and ret + (setq ret (mime-content-disposition-filename ret)) + (std11-strip-quoted-string ret) + )) + (let ((ret (mime-entity-content-type entity))) + (and ret + (setq ret + (cdr + (let ((param (mime-content-type-parameters ret))) + (or (assoc "name" param) + (assoc "x-name" param)) + ))) + (std11-strip-quoted-string ret) + )) + (if (member (mime-entity-encoding entity) + mime-view-uuencode-encoding-name-list) + (mime-raw-get-uu-filename)) + "")) + + +(defsubst mime-raw-point-to-entity-node-id (point &optional message-info) + "Return entity-node-id from POINT in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (mime-entity-node-id (mime-raw-find-entity-from-point point message-info))) + +(defsubst mime-raw-point-to-entity-number (point &optional message-info) + "Return entity-number from POINT in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (mime-entity-number (mime-raw-find-entity-from-point point message-info))) + +(defun mime-raw-flatten-message-info (&optional message-info) + "Return list of entity in mime-raw-buffer. +If optional argument MESSAGE-INFO is not specified, +`mime-raw-message-info' is used." + (or message-info + (setq message-info mime-raw-message-info)) + (let ((dest (list message-info)) + (rcl (mime-entity-children message-info))) + (while rcl + (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl)))) + (setq rcl (cdr rcl))) + dest)) + + +;;; @ presentation of preview +;;; + +;;; @@ entity-button +;;; -;;; @ entity-button +;;; @@@ predicate function ;;; -(defvar mime-view-content-button-visible-ctype-list - '("application/pgp")) +(defun mime-view-entity-button-visible-p (entity) + "Return non-nil if header of ENTITY is visible. +Please redefine this function if you want to change default setting." + (let ((media-type (mime-entity-media-type entity)) + (media-subtype (mime-entity-media-subtype entity))) + (or (not (eq media-type 'application)) + (and (not (eq media-subtype 'x-selection)) + (or (not (eq media-subtype 'octet-stream)) + (let ((mother-entity (mime-entity-parent entity))) + (or (not (eq (mime-entity-media-type mother-entity) + 'multipart)) + (not (eq (mime-entity-media-subtype mother-entity) + 'encrypted))) + ) + ))))) -(defun mime-view-insert-entity-button (entity message-info subj) +;;; @@@ entity button generator +;;; + +(defun mime-view-insert-entity-button (entity subject) "Insert entity-button of ENTITY." (let ((entity-node-id (mime-entity-node-id entity)) (params (mime-entity-parameters entity))) @@ -122,12 +348,12 @@ message/partial, it is called `mother-buffer'.") (setq access-type (cdr access-type)) (if server (format "%s %s ([%s] %s)" - num subj access-type (cdr server)) + num subject access-type (cdr server)) (let ((site (cdr (assoc "site" params))) (dir (cdr (assoc "directory" params))) ) (format "%s %s ([%s] %s:%s)" - num subj access-type site dir) + num subject access-type site dir) ))) ) (t @@ -136,7 +362,7 @@ message/partial, it is called `mother-buffer'.") (charset (cdr (assoc "charset" params))) (encoding (mime-entity-encoding entity))) (concat - num " " subj + num " " subject (let ((rest (format " <%s/%s%s%s>" media-type media-subtype @@ -153,46 +379,11 @@ message/partial, it is called `mother-buffer'.") (function mime-preview-play-current-entity)) )) -(defun mime-view-entity-button-function (entity message-info subj) - "Insert entity-button of ENTITY conditionally. -Please redefine this function if you want to change default setting." - (let ((media-type (mime-entity-media-type entity)) - (media-subtype (mime-entity-media-subtype entity))) - (or (mime-root-entity-p entity) - (and (eq media-type 'application) - (or (eq media-subtype 'x-selection) - (and (eq media-subtype 'octet-stream) - (let ((mother-entity - (mime-raw-entity-parent entity message-info))) - (and (eq (mime-entity-media-type mother-entity) - 'multipart) - (eq (mime-entity-media-subtype mother-entity) - 'encrypted) - ))))) - (mime-view-insert-entity-button entity message-info subj) - ))) - - -;;; @ entity-header -;;; -;;; @@ predicate function +;;; @@ entity-header ;;; -(defvar mime-view-childrens-header-showing-Content-Type-list - '("message/rfc822" "message/news")) - -(defun mime-view-header-visible-p (entity message-info) - "Return non-nil if header of ENTITY is visible." - (let ((entity-node-id (mime-entity-node-id entity))) - (or (null entity-node-id) - (member (mime-entity-type/subtype - (mime-raw-find-entity-from-node-id - (cdr entity-node-id) message-info)) - mime-view-childrens-header-showing-Content-Type-list) - ))) - -;;; @@ entity header filter +;;; @@@ entity header filter ;;; (defvar mime-view-content-header-filter-alist nil) @@ -202,20 +393,7 @@ Please redefine this function if you want to change default setting." (eword-decode-header) ) -(defun mime-view-display-header (beg end) - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime-raw-buffer beg end) - (let ((f (cdr (assq mime-preview-original-major-mode - mime-view-content-header-filter-alist)))) - (if (functionp f) - (funcall f) - (mime-view-default-content-header-filter) - )) - (run-hooks 'mime-view-content-header-filter-hook) - )) - -;;; @@ entity field cutter +;;; @@@ entity field cutter ;;; (defvar mime-view-ignored-field-list @@ -258,93 +436,122 @@ Each elements are regexp of field-name.") )))) -;;; @ entity-body +;;; @@ entity-body ;;; -;;; @@ predicate function +;;; @@@ predicate function ;;; -(defvar mime-view-body-visible-condition - '(type - (nil) - (text subtype - (plain) - (enriched) - (rfc822-headers) - (richtext) - (x-latex) - (x-pgp)) - (application subtype - (octet-stream encoding - (nil) - ("7bit") - ("8bit")) - (pgp) - (x-latex) - (x-selection) - (x-comment)) - (message subtype - (delivery-status))) - "Condition-tree to be able to display body of entity.") - -(defun mime-view-body-visible-p (entity message-info) - "Return non-nil if body of ENTITY is visible." - (ctree-match-calist - mime-view-body-visible-condition - (list* (cons 'type (mime-entity-media-type entity)) - (cons 'subtype (mime-entity-media-subtype entity)) - (cons 'encoding (mime-entity-encoding entity)) - (cons 'major-mode major-mode) - (mime-entity-parameters entity)))) - -;; (defvar mime-view-visible-media-type-list -;; '("text/plain" nil "text/richtext" "text/enriched" -;; "text/rfc822-headers" -;; "text/x-latex" "application/x-latex" -;; "message/delivery-status" -;; "application/pgp" "text/x-pgp" -;; "application/octet-stream" -;; "application/x-selection" "application/x-comment") -;; "*List of media-types to be able to display in MIME-preview buffer. -;; Each elements are string of TYPE/SUBTYPE, e.g. \"text/plain\".") - -;; (defun mime-view-body-visible-p (entity message-info) -;; "Return non-nil if body of ENTITY is visible." -;; (let ((media-type (mime-entity-media-type entity)) -;; (media-subtype (mime-entity-media-subtype entity)) -;; (ctype (mime-entity-type/subtype entity))) -;; (and (member ctype mime-view-visible-media-type-list) -;; (if (and (eq media-type 'application) -;; (eq media-subtype 'octet-stream)) -;; (member (mime-entity-encoding entity) '(nil "7bit" "8bit")) -;; t)))) - - -;;; @@ entity filter +(defun mime-calist::field-match-method-as-default-rule (calist + field-type field-value) + (let ((s-field (assq field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist) + ) + (t calist)))) + +(define-calist-field-match-method + 'header #'mime-calist::field-match-method-as-default-rule) + +(define-calist-field-match-method + 'body #'mime-calist::field-match-method-as-default-rule) + + +(defvar mime-preview-condition nil + "Condition-tree about how to display entity.") + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . nil) + (body . visible))) +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . "7bit") + (body . visible))) +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . octet-stream) + (encoding . "8bit") + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . pgp) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-latex) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-selection) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . application)(subtype . x-comment) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . delivery-status) + (body . visible))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((body . visible) + (body-presentation-method . mime-preview-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . nil) + (body . visible) + (body-presentation-method . mime-preview-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . enriched) + (body . visible) + (body-presentation-method . mime-preview-text/enriched))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . richtext) + (body . visible) + (body-presentation-method . mime-preview-text/richtext))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . text)(subtype . t) + (body . visible) + (body-presentation-method . mime-preview-text/plain))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . multipart)(subtype . alternative) + (body . visible) + (body-presentation-method . mime-preview-multipart/alternative))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . partial) + (body-presentation-method + . mime-preview-message/partial-button))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . rfc822) + (body-presentation-method . nil) + (childrens-situation (header . visible) + (entity-button . invisible)))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . news) + (body-presentation-method . nil) + (childrens-situation (header . visible) + (entity-button . invisible)))) + + +;;; @@@ entity presentation ;;; -(defvar mime-view-content-filter-alist - '(("text/enriched" . mime-view-filter-for-text/enriched) - ("text/richtext" . mime-view-filter-for-text/richtext) - (t . mime-view-filter-for-text/plain) - ) - "Alist of media-types vs. corresponding MIME-preview filter functions. -Each element looks like (TYPE/SUBTYPE . FUNCTION) or (t . FUNCTION). -TYPE/SUBTYPE is a string of media-type and FUNCTION is a filter -function. t means default media-type.") - -(defun mime-view-display-body (start end entity message-info subj) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime-raw-buffer start end) - (let* ((ctype (mime-entity-type/subtype entity)) - (params (mime-entity-parameters entity)) - (encoding (mime-entity-encoding entity)) - (f (cdr (or (assoc ctype mime-view-content-filter-alist) - (assq t mime-view-content-filter-alist))))) - (and (functionp f) - (funcall f ctype params encoding)) - ))) +(autoload 'mime-preview-text/plain "mime-text") +(autoload 'mime-preview-text/enriched "mime-text") +(autoload 'mime-preview-text/richtext "mime-text") (defvar mime-view-announcement-for-message/partial (if (and (>= emacs-major-version 19) window-system) @@ -357,7 +564,7 @@ function. t means default media-type.") \[[ Please press `v' key in this buffer. ]]" )) -(defun mime-view-insert-message/partial-button () +(defun mime-preview-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) @@ -370,83 +577,176 @@ function. t means default media-type.") #'mime-preview-play-current-entity) )) +(defun mime-preview-multipart/mixed (entity situation) + (let ((children (mime-entity-children entity)) + (default-situation + (cdr (assq 'childrens-situation situation)))) + (while children + (mime-view-display-entity (car children) + (save-excursion + (set-buffer (mime-entity-buffer entity)) + mime-raw-message-info) + (current-buffer) + default-situation) + (setq children (cdr children)) + ))) -;;; @ entity separator -;;; - -(defun mime-view-entity-separator-function (entity message-info) - "Insert entity-separator of ENTITY conditionally. -Please redefine this function if you want to change default setting." - (or (mime-view-header-visible-p entity message-info) - (mime-view-body-visible-p entity message-info) - (progn - (goto-char (point-max)) - (insert "\n") - ))) +(defcustom mime-view-type-subtype-score-alist + '(((text . enriched) . 3) + ((text . richtext) . 2) + ((text . plain) . 1) + (t . 0)) + "Alist MEDIA-TYPE vs corresponding score. +MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." + :group 'mime-view + :type '(repeat (cons (choice :tag "Media-Type" + (item :tag "Type/Subtype" + (cons symbol symbol)) + (item :tag "Type" symbol) + (item :tag "Default" t)) + integer))) + +(defun mime-preview-multipart/alternative (entity situation) + (let* ((children (mime-entity-children entity)) + (default-situation + (cdr (assq 'childrens-situation situation))) + (i 0) + (p 0) + (max-score 0) + (situations + (mapcar (function + (lambda (child) + (let ((situation + (or (ctree-match-calist + mime-preview-condition + (append (mime-entity-situation child) + default-situation)) + default-situation))) + (if (cdr (assq 'body-presentation-method situation)) + (let ((score + (cdr + (or (assoc + (cons + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation))) + mime-view-type-subtype-score-alist) + (assq + (cdr (assq 'type situation)) + mime-view-type-subtype-score-alist) + (assq + t + mime-view-type-subtype-score-alist) + )))) + (if (> score max-score) + (setq p i + max-score score) + ))) + (setq i (1+ i)) + situation) + )) + children))) + (setq i 0) + (while children + (let ((child (car children)) + (situation (car situations))) + (mime-view-display-entity child + (save-excursion + (set-buffer (mime-entity-buffer child)) + mime-raw-message-info) + (current-buffer) + default-situation + (if (= i p) + situation + (del-alist 'body-presentation-method + (copy-alist situation)))) + ) + (setq children (cdr children) + situations (cdr situations) + i (1+ i)) + ))) ;;; @ acting-condition ;;; -(defvar mime-acting-condition - '(((type . text)(subtype . plain) - (method "tm-plain" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . text)(subtype . html) - (method "tm-html" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - ((type . text)(subtype . x-rot13-47) - (method . mime-method-to-display-caesar) - (mode . "play") - ) - ((type . text)(subtype . x-rot13-47-48) - (method . mime-method-to-display-caesar) - (mode . "play") - ) - - ((type . audio)(subtype . basic) - (method "tm-au" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . image) - (method "tm-image" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - - ((type . video)(subtype . mpeg) - (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . application)(subtype . postscript) - (method "tm-ps" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . application)(subtype . octet-stream) - (method . mime-method-to-save)(mode "play" "print") - ) +(defvar mime-acting-condition nil + "Condition-tree about how to process entity.") + +(if (file-readable-p mailcap-file) + (let ((entries (mailcap-parse-file))) + (while entries + (let ((entry (car entries)) + view print shared) + (while entry + (let* ((field (car entry)) + (field-type (car field))) + (cond ((eq field-type 'view) (setq view field)) + ((eq field-type 'print) (setq print field)) + ((memq field-type '(compose composetyped edit))) + (t (setq shared (cons field shared)))) + ) + (setq entry (cdr entry)) + ) + (setq shared (nreverse shared)) + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared (list '(mode . "play")(cons 'method (cdr view))))) + (if print + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared + (list '(mode . "print")(cons 'method (cdr view)))) + )) + ) + (setq entries (cdr entries)) + ))) - ((type . message)(subtype . external-body) - ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) - ) - ((type . message)(subtype . rfc822) - (method . mime-method-to-display-message/rfc822) - (mode . "play") - ) - ((type . message)(subtype . partial) - (method . mime-method-to-store-message/partial) - (mode . "play") - ) - - ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - (mode . "play") - ) - ((method . mime-method-to-save)(mode . "extract")) - )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (mode . "play") + (method . mime-method-to-detect) + )) + +(ctree-set-calist-with-default + 'mime-acting-condition + '((mode . "extract") + (method . mime-method-to-save))) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47)(mode . "play") + (method . mime-method-to-display-caesar) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47-48)(mode . "play") + (method . mime-method-to-display-caesar) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . rfc822)(mode . "play") + (method . mime-method-to-display-message/rfc822) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . partial)(mode . "play") + (method . mime-method-to-store-message/partial) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("access-type" . "anon-ftp") + (method . mime-method-to-display-message/external-ftp) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (method . mime-method-to-save) + )) ;;; @ quitting method @@ -457,11 +757,11 @@ Please redefine this function if you want to change default setting." . mime-preview-quitting-method-for-mime-show-message-mode)) "Alist of major-mode vs. quitting-method of mime-view.") -(defvar mime-view-over-to-previous-method-alist nil) -(defvar mime-view-over-to-next-method-alist nil) +(defvar mime-preview-over-to-previous-method-alist nil + "Alist of major-mode vs. over-to-previous-method of mime-view.") -(defvar mime-view-show-summary-method nil - "Alist of major-mode vs. show-summary-method.") +(defvar mime-preview-over-to-next-method-alist nil + "Alist of major-mode vs. over-to-next-method of mime-view.") ;;; @ following method @@ -506,226 +806,93 @@ The compressed face will be piped to this command.") )))) -;;; @ miscellaneous -;;; - -(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode")) - -(defvar mime-raw-buffer-coding-system-alist - `((t . ,(mime-charset-to-coding-system default-mime-charset))) - "Alist of major-mode vs. corresponding coding-system of `mime-raw-buffer'.") - - ;;; @ buffer setup ;;; -(defvar mime-view-redisplay nil) - -(defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf) - (if ibuf - (progn - (get-buffer ibuf) - (set-buffer ibuf) - )) - (or mime-view-redisplay - (setq mime-raw-message-info (mime-parse-message ctl encoding)) - ) - (let* ((message-info mime-raw-message-info) - (pcl (mime-raw-flatten-message-info message-info)) - (the-buf (current-buffer)) - (mode major-mode) - ) - (or obuf - (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) - (set-buffer (get-buffer-create obuf)) - (let ((inhibit-read-only t)) - ;;(setq buffer-read-only nil) - (widen) - (erase-buffer) - (setq mime-raw-buffer the-buf) - (setq mime-preview-original-major-mode mode) - (setq major-mode 'mime-view-mode) - (setq mode-name "MIME-View") - (while pcl - (mime-view-display-entity (car pcl) message-info the-buf obuf) - (setq pcl (cdr pcl)) - ) - (set-buffer-modified-p nil) - ) - (setq buffer-read-only t) - (set-buffer the-buf) - ) - (setq mime-preview-buffer obuf) - ) - -(defun mime-view-display-entity (entity message-info ibuf obuf) - "Display ENTITY." - (let* ((beg (mime-entity-point-min entity)) +(defun mime-view-display-entity (entity message-info obuf + default-situation + &optional situation) + (let* ((raw-buffer (mime-entity-buffer entity)) + (start (mime-entity-point-min entity)) (end (mime-entity-point-max entity)) - (media-type (mime-entity-media-type entity)) - (media-subtype (mime-entity-media-subtype entity)) - (ctype (if media-type - (if media-subtype - (format "%s/%s" media-type media-subtype) - (symbol-name media-type) - ))) - (params (mime-entity-parameters entity)) - (encoding (mime-entity-encoding entity)) - (entity-node-id (mime-entity-node-id entity)) - he e nb ne subj) - (set-buffer ibuf) - (goto-char beg) - (setq he (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - end)) - (if (> he end) - (setq he end) + original-major-mode end-of-header e nb ne subj) + (set-buffer raw-buffer) + (setq original-major-mode major-mode) + (goto-char start) + (setq end-of-header (if (re-search-forward "^$" nil t) + (1+ (match-end 0)) + end)) + (if (> end-of-header end) + (setq end-of-header end) ) (save-restriction - (narrow-to-region beg end) - (setq subj - (eword-decode-string - (mime-raw-get-subject params encoding))) + (narrow-to-region start end) + (setq subj (eword-decode-string (mime-raw-get-subject entity))) ) - (set-buffer obuf) - (setq nb (point)) - (narrow-to-region nb nb) - (mime-view-entity-button-function entity message-info subj) - (if (mime-view-header-visible-p entity message-info) - (mime-view-display-header beg he) - ) - (if (and (null entity-node-id) - (member - ctype mime-view-content-button-visible-ctype-list)) - (save-excursion - (goto-char (point-max)) - (mime-view-insert-entity-button entity message-info subj) - )) - (cond ((mime-view-body-visible-p entity message-info) - (mime-view-display-body he end entity message-info subj) - ) - ((and (eq media-type 'message)(eq media-subtype 'partial)) - (mime-view-insert-message/partial-button) - ) - ((and (null entity-node-id) - (null (mime-entity-children message-info)) - ) - (goto-char (point-max)) - (mime-view-insert-entity-button entity message-info subj) - )) - (mime-view-entity-separator-function entity message-info) - (setq ne (point-max)) - (widen) - (put-text-property nb ne 'mime-view-raw-buffer ibuf) - (put-text-property nb ne 'mime-view-entity entity) - (goto-char ne) - )) - -(defun mime-raw-get-uu-filename (param &optional encoding) - (if (member (or encoding - (cdr (assq 'encoding param)) - ) - mime-view-uuencode-encoding-name-list) - (save-excursion - (or (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - )) - "")) - )) - -(defun mime-raw-get-subject (param &optional encoding) - (or (std11-find-field-body '("Content-Description" "Subject")) - (let (ret) - (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - )) - (mime-raw-get-uu-filename param encoding) - "")) - - -;;; @ entity information -;;; - -(defsubst mime-raw-find-entity-from-node-id (entity-node-id - &optional message-info) - "Return entity from ENTITY-NODE-ID in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-raw-find-entity-from-number (reverse entity-node-id) message-info)) - -(defun mime-raw-find-entity-from-number (entity-number &optional message-info) - "Return entity from ENTITY-NUMBER in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (if (eq entity-number t) - message-info - (let ((sn (car entity-number))) - (if (null sn) - message-info - (let ((rc (nth sn (mime-entity-children message-info)))) - (if rc - (mime-raw-find-entity-from-number (cdr entity-number) rc) + (or situation + (setq situation + (or (ctree-match-calist mime-preview-condition + (append (mime-entity-situation entity) + default-situation)) + default-situation))) + (let ((button-is-invisible + (eq (cdr (assq 'entity-button situation)) 'invisible)) + (header-is-visible + (eq (cdr (assq 'header situation)) 'visible)) + (body-presentation-method + (cdr (assq 'body-presentation-method situation))) + (children (mime-entity-children entity))) + (set-buffer obuf) + (setq nb (point)) + (narrow-to-region nb nb) + (or button-is-invisible + (if (mime-view-entity-button-visible-p entity) + (mime-view-insert-entity-button entity subj) )) - )))) - -(defun mime-raw-find-entity-from-point (point &optional message-info) - "Return entity from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (if (and (<= (mime-entity-point-min message-info) point) - (<= point (mime-entity-point-max message-info))) - (let ((children (mime-entity-children message-info))) - (catch 'tag - (while children - (let ((ret - (mime-raw-find-entity-from-point point (car children)))) - (if ret - (throw 'tag ret) + (if header-is-visible + (save-restriction + (narrow-to-region (point)(point)) + (insert-buffer-substring raw-buffer start end-of-header) + (let ((f (cdr (assq original-major-mode + mime-view-content-header-filter-alist)))) + (if (functionp f) + (funcall f) + (mime-view-default-content-header-filter) )) - (setq children (cdr children))) - message-info)))) - -(defsubst mime-raw-point-to-entity-node-id (point &optional message-info) - "Return entity-node-id from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-entity-node-id (mime-raw-find-entity-from-point point message-info))) - -(defsubst mime-raw-point-to-entity-number (point &optional message-info) - "Return entity-number from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (reverse (mime-raw-point-to-entity-node-id point message-id))) - -(defsubst mime-raw-entity-parent (entity &optional message-info) - "Return mother entity of ENTITY. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-raw-find-entity-from-node-id - (cdr (mime-entity-node-id entity) message-info))) - -(defun mime-raw-flatten-message-info (&optional message-info) - "Return list of entity in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (let ((dest (list message-info)) - (rcl (mime-entity-children message-info))) - (while rcl - (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl)))) - (setq rcl (cdr rcl))) - dest)) + (run-hooks 'mime-view-content-header-filter-hook) + )) + (cond ((eq body-presentation-method 'with-filter) + (let ((body-filter (cdr (assq 'body-filter situation)))) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (insert-buffer-substring raw-buffer end-of-header end) + (funcall body-filter situation) + ))) + (children) + ((functionp body-presentation-method) + (funcall body-presentation-method entity situation) + ) + (t + (when button-is-invisible + (goto-char (point-max)) + (mime-view-insert-entity-button entity subj) + ) + (or header-is-visible + (progn + (goto-char (point-max)) + (insert "\n") + )) + )) + (setq ne (point-max)) + (widen) + (put-text-property nb ne 'mime-view-entity entity) + (goto-char ne) + (if children + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-preview-multipart/mixed entity situation) + )) + ))) ;;; @ MIME viewer mode @@ -801,8 +968,6 @@ If optional argument MESSAGE-INFO is not specified, (define-key mime-view-mode-map "q" (function mime-preview-quit)) (define-key mime-view-mode-map - "h" (function mime-preview-show-summary)) - (define-key mime-view-mode-map "\C-c\C-x" (function mime-preview-kill-buffer)) ;; (define-key mime-view-mode-map ;; "<" (function beginning-of-buffer)) @@ -864,7 +1029,61 @@ If optional argument MESSAGE-INFO is not specified, (bury-buffer buf) )))) -(defun mime-view-mode (&optional mother ctl encoding ibuf obuf +(defvar mime-view-redisplay nil) + +(defun mime-view-display-message (message &optional preview-buffer + mother default-keymap-or-function) + (mime-maybe-hide-echo-buffer) + (let ((win-conf (current-window-configuration)) + (raw-buffer (mime-entity-buffer message))) + (or preview-buffer + (setq preview-buffer + (concat "*Preview-" (buffer-name raw-buffer) "*"))) + (set-buffer raw-buffer) + (setq mime-raw-message-info (mime-parse-message)) + (setq mime-preview-buffer preview-buffer) + (let ((inhibit-read-only t)) + (switch-to-buffer preview-buffer) + (widen) + (erase-buffer) + (setq mime-raw-buffer raw-buffer) + (if mother + (setq mime-mother-buffer mother) + ) + (setq mime-preview-original-window-configuration win-conf) + (setq major-mode 'mime-view-mode) + (setq mode-name "MIME-View") + (mime-view-display-entity message message + preview-buffer + '((entity-button . invisible) + (header . visible) + )) + (mime-view-define-keymap default-keymap-or-function) + (let ((point + (next-single-property-change (point-min) 'mime-view-entity))) + (if point + (goto-char point) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + )) + (run-hooks 'mime-view-mode-hook) + )) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + ) + +(defun mime-view-buffer (&optional raw-buffer preview-buffer mother + default-keymap-or-function) + (interactive) + (mime-view-display-message + (save-excursion + (if raw-buffer (set-buffer raw-buffer)) + (mime-parse-message) + ) + preview-buffer mother default-keymap-or-function)) + +(defun mime-view-mode (&optional mother ctl encoding + raw-buffer preview-buffer default-keymap-or-function) "Major mode for viewing MIME message. @@ -884,33 +1103,18 @@ v Decode current content as `play mode' e Decode current content as `extract mode' C-c C-p Decode current content as `print mode' a Followup to current content. -x Display X-Face q Quit button-2 Move to point under the mouse cursor and decode current content as `play mode' " (interactive) - (mime-maybe-hide-echo-buffer) - (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf)) - (win-conf (current-window-configuration)) - ) - (prog1 - (switch-to-buffer ret) - (setq mime-preview-original-window-configuration win-conf) - (if mother - (progn - (setq mime-mother-buffer mother) - )) - (mime-view-define-keymap default-keymap-or-function) - (let ((point - (next-single-property-change (point-min) 'mime-view-entity))) - (if point - (goto-char point) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - )) - (run-hooks 'mime-view-mode-hook) - ))) + (mime-view-display-message + (save-excursion + (if raw-buffer (set-buffer raw-buffer)) + (or mime-view-redisplay + (mime-parse-message ctl encoding)) + ) + preview-buffer mother default-keymap-or-function)) ;;; @@ playing @@ -941,24 +1145,12 @@ It decodes current entity to call internal or external method as ;;; @@ following ;;; -(defun mime-preview-original-major-mode () - "Return major-mode of original buffer. -If a current buffer has mime-mother-buffer, return original major-mode -of the mother-buffer." - (if mime-mother-buffer - (save-excursion - (set-buffer mime-mother-buffer) - (mime-preview-original-major-mode) - ) - mime-preview-original-major-mode)) - (defun mime-preview-follow-current-entity () "Write follow message to current entity. It calls following-method selected from variable `mime-view-following-method-alist'." (interactive) - (let ((message-info (get-text-property (point-min) 'mime-view-entity)) - entity) + (let (entity) (while (null (setq entity (get-text-property (point) 'mime-view-entity))) (backward-char) @@ -1009,7 +1201,7 @@ It calls following-method selected from variable (setq p-end (point-max)) )) )) - (let* ((mode (mime-preview-original-major-mode)) + (let* ((mode (mime-preview-original-major-mode 'recursive)) (new-name (format "%s-%s" (buffer-name) (reverse entity-node-id))) new-buf @@ -1021,16 +1213,7 @@ It calls following-method selected from variable (erase-buffer) (insert-buffer-substring the-buf p-beg p-end) (goto-char (point-min)) - (if (mime-view-header-visible-p entity message-info) - (delete-region (goto-char (point-min)) - (if (re-search-forward "^$" nil t) - (match-end 0) - (point-min))) - ) - (goto-char (point-min)) - (insert "\n") - (goto-char (point-min)) - (let ((entity-node-id (mime-entity-node-id entity)) ci str) + (let ((entity-node-id (mime-entity-node-id entity)) ci str) (while (progn (setq str @@ -1132,17 +1315,20 @@ If there is no upper entity, call function `mime-preview-quit'." (defun mime-preview-move-to-previous () "Move to previous entity. If there is no previous entity, it calls function registered in -variable `mime-view-over-to-previous-method-alist'." +variable `mime-preview-over-to-previous-method-alist'." (interactive) (while (null (get-text-property (point) 'mime-view-entity)) (backward-char) ) - (let ((point - (previous-single-property-change (point) 'mime-view-entity))) + (let ((point (previous-single-property-change (point) 'mime-view-entity))) (if point - (goto-char point) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-previous-method-alist))) + (if (get-text-property (1- point) 'mime-view-entity) + (goto-char point) + (goto-char (1- point)) + (mime-preview-move-to-previous) + ) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) (if f (funcall (cdr f)) )) @@ -1151,13 +1337,20 @@ variable `mime-view-over-to-previous-method-alist'." (defun mime-preview-move-to-next () "Move to next entity. If there is no previous entity, it calls function registered in -variable `mime-view-over-to-next-method-alist'." +variable `mime-preview-over-to-next-method-alist'." (interactive) + (while (null (get-text-property (point) 'mime-view-entity)) + (forward-char) + ) (let ((point (next-single-property-change (point) 'mime-view-entity))) (if point - (goto-char point) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-next-method-alist))) + (progn + (goto-char point) + (if (null (get-text-property point 'mime-view-entity)) + (mime-preview-move-to-next) + )) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) (if f (funcall (cdr f)) )) @@ -1166,14 +1359,14 @@ variable `mime-view-over-to-next-method-alist'." (defun mime-preview-scroll-up-entity (&optional h) "Scroll up current entity. If reached to (point-max), it calls function registered in variable -`mime-view-over-to-next-method-alist'." +`mime-preview-over-to-next-method-alist'." (interactive) (or h (setq h (1- (window-height))) ) (if (= (point) (point-max)) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-next-method-alist))) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) (if f (funcall (cdr f)) )) @@ -1189,30 +1382,20 @@ If reached to (point-max), it calls function registered in variable (defun mime-preview-scroll-down-entity (&optional h) "Scroll down current entity. If reached to (point-min), it calls function registered in variable -`mime-view-over-to-previous-method-alist'." +`mime-preview-over-to-previous-method-alist'." (interactive) (or h (setq h (1- (window-height))) ) (if (= (point) (point-min)) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-previous-method-alist))) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) (if f (funcall (cdr f)) )) - (let (point) - (save-excursion - (catch 'tag - (while (> (point) 1) - (if (setq point - (previous-single-property-change (point) - 'mime-view-entity)) - (throw 'tag t) - ) - (backward-char) - ) - (setq point (point-min)) - )) + (let ((point + (or (previous-single-property-change (point) 'mime-view-entity) + (point-min)))) (forward-line (- h)) (if (< (point) point) (goto-char point) @@ -1237,23 +1420,12 @@ If reached to (point-min), it calls function registered in variable It calls function registered in variable `mime-preview-quitting-method-alist'." (interactive) - (let ((r (assq mime-preview-original-major-mode + (let ((r (assq (mime-preview-original-major-mode) mime-preview-quitting-method-alist))) (if r (funcall (cdr r)) ))) -(defun mime-preview-show-summary () - "Show summary. -It calls function registered in variable -`mime-view-show-summary-method'." - (interactive) - (let ((r (assq mime-preview-original-major-mode - mime-view-show-summary-method))) - (if r - (funcall (cdr r)) - ))) - (defun mime-preview-kill-buffer () (interactive) (kill-buffer (current-buffer))