X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=ffd2579467fe8629da4f4a8e7c2da1d9d13286a3;hb=aaa55b0b1e0f5c539843a19911cdb25c006034b4;hp=f4a9fa6ddf1d34dd01c33e96802bee9a85e24813;hpb=a6c18e6c4cc5c2eb55bfc8164ee251d8798ddad7;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index f4a9fa6..ffd2579 100644 --- a/mime-view.el +++ b/mime-view.el @@ -27,10 +27,7 @@ ;;; Code: -(require 'std11) -(require 'mel) -(require 'eword-decode) -(require 'mime-parse) +(require 'mime) (require 'semi-def) (require 'calist) (require 'alist) @@ -41,9 +38,10 @@ ;;; (defconst mime-view-version-string - `,(concat (car mime-module-version) " MIME-View " - (mapconcat #'number-to-string (cddr mime-module-version) ".") - " (" (cadr mime-module-version) ")")) + `,(concat (car mime-user-interface-version) " MIME-View " + (mapconcat #'number-to-string + (cddr mime-user-interface-version) ".") + " (" (cadr mime-user-interface-version) ")")) ;;; @ variables @@ -64,50 +62,14 @@ :type 'file) -;;; @ buffer local variables +;;; @ in raw-buffer (representation space) ;;; -;;; @@ in raw-buffer -;;; - -(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: - -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) -(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) @@ -116,12 +78,30 @@ raw-buffer.") "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.") +`binary' or `cooked'.") + + +(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-message-structure' is used." + (or message-info + (setq message-info mime-message-structure)) + (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 +;;; @ in preview-buffer (presentation space) ;;; (defvar mime-mother-buffer nil @@ -134,90 +114,87 @@ 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-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-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))) + )) -(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)))) +(defun mime-view-entity-title (entity) + (or (mime-read-field 'Content-Description entity) + (mime-read-field 'Subject entity) + (mime-entity-filename entity) + "")) + (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-message-structure' 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-info))) - -(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)))) +`mime-message-structure' 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." +`mime-message-structure' is used." (or message-info - (setq message-info mime-raw-message-info)) + (setq message-info mime-message-structure)) (let ((dest (list message-info)) (rcl (mime-entity-children message-info))) (while rcl @@ -254,10 +231,11 @@ Please redefine this function if you want to change default setting." ;;; @@@ entity button generator ;;; -(defun mime-view-insert-entity-button (entity message-info subj) +(defun mime-view-insert-entity-button (entity) "Insert entity-button of ENTITY." (let ((entity-node-id (mime-entity-node-id entity)) - (params (mime-entity-parameters entity))) + (params (mime-entity-parameters entity)) + (subject (mime-view-entity-title entity))) (mime-insert-button (let ((access-type (assoc "access-type" params)) (num (or (cdr (assoc "x-part-number" params)) @@ -274,12 +252,12 @@ Please redefine this function if you want to change default setting." (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 @@ -288,7 +266,7 @@ Please redefine this function if you want to change default setting." (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 @@ -309,18 +287,11 @@ Please redefine this function if you want to change default setting." ;;; @@ entity-header ;;; -;;; @@@ entity header filter -;;; - -(defvar mime-view-content-header-filter-alist nil) - -(defun mime-view-default-content-header-filter () - (mime-view-cut-header) - (eword-decode-header) - ) - -;;; @@@ entity field cutter -;;; +(defvar mime-header-presentation-method-alist nil + "Alist of major mode vs. corresponding header-presentation-method functions. +Each element looks like (SYMBOL . FUNCTION). +SYMBOL must be major mode in raw-buffer or t. t means default. +Interface of FUNCTION must be (ENTITY SITUATION).") (defvar mime-view-ignored-field-list '(".*Received" ".*Path" ".*Id" "References" @@ -331,36 +302,10 @@ Please redefine this function if you want to change default setting." "All fields that match this list will be hidden in MIME preview buffer. Each elements are regexp of field-name.") -(defvar mime-view-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-view-ignored-field-list) - ":")) - (defvar mime-view-visible-field-list '("Dnas.*" "Message-Id") "All fields that match this list will be displayed in MIME preview buffer. Each elements are regexp of field-name.") -(defun mime-view-cut-header () - (goto-char (point-min)) - (while (re-search-forward mime-view-ignored-field-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (buffer-substring beg end)) - ) - (catch 'visible - (let ((rest mime-view-visible-field-list)) - (while rest - (if (string-match (car rest) name) - (throw 'visible nil) - ) - (setq rest (cdr rest)))) - (delete-region beg - (save-excursion - (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t) - (match-beginning 0) - (point-max)))) - )))) - ;;; @@ entity-body ;;; @@ -422,42 +367,42 @@ Each elements are regexp of field-name.") (ctree-set-calist-strictly 'mime-preview-condition '((body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . nil) (body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . enriched) (body . visible) - (body-presentation-method . mime-preview-text/enriched))) + (body-presentation-method . mime-display-text/enriched))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . richtext) (body . visible) - (body-presentation-method . mime-preview-text/richtext))) + (body-presentation-method . mime-display-text/richtext))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . t) (body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . multipart)(subtype . alternative) (body . visible) - (body-presentation-method . mime-preview-multipart/alternative))) + (body-presentation-method . mime-display-multipart/alternative))) (ctree-set-calist-strictly 'mime-preview-condition '((type . message)(subtype . partial) (body-presentation-method - . mime-preview-message/partial-button))) + . mime-display-message/partial-button))) (ctree-set-calist-strictly 'mime-preview-condition '((type . message)(subtype . rfc822) @@ -475,9 +420,9 @@ Each elements are regexp of field-name.") ;;; @@@ entity presentation ;;; -(autoload 'mime-preview-text/plain "mime-text") -(autoload 'mime-preview-text/enriched "mime-text") -(autoload 'mime-preview-text/richtext "mime-text") +(autoload 'mime-display-text/plain "mime-text") +(autoload 'mime-display-text/enriched "mime-text") +(autoload 'mime-display-text/richtext "mime-text") (defvar mime-view-announcement-for-message/partial (if (and (>= emacs-major-version 19) window-system) @@ -490,7 +435,7 @@ Each elements are regexp of field-name.") \[[ Please press `v' key in this buffer. ]]" )) -(defun mime-preview-message/partial-button (&optional entity situation) +(defun mime-display-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) @@ -503,17 +448,12 @@ Each elements are regexp of field-name.") #'mime-preview-play-current-entity) )) -(defun mime-preview-multipart/mixed (entity situation) +(defun mime-display-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-raw-buffer) - mime-raw-message-info) - mime-raw-buffer (current-buffer) - default-situation) + (mime-display-entity (car children) nil default-situation) (setq children (cdr children)) ))) @@ -526,13 +466,14 @@ Each elements are regexp of field-name.") 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)) + (cons :tag "Type/Subtype" + (symbol :tag "Primary-type") + (symbol :tag "Subtype")) + (symbol :tag "Type") + (const :tag "Default" t)) integer))) -(defun mime-preview-multipart/alternative (entity situation) +(defun mime-display-multipart/alternative (entity situation) (let* ((children (mime-entity-children entity)) (default-situation (cdr (assq 'childrens-situation situation))) @@ -545,13 +486,8 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (let ((situation (or (ctree-match-calist mime-preview-condition - (append - (or (mime-entity-content-type child) - (make-mime-content-type 'text 'plain)) - (list* (cons 'encoding - (mime-entity-encoding child)) - (cons 'major-mode major-mode) - default-situation))) + (append (mime-entity-situation child) + default-situation)) default-situation))) (if (cdr (assq 'body-presentation-method situation)) (let ((score @@ -578,17 +514,12 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." children))) (setq i 0) (while children - (let ((situation (car situations))) - (mime-view-display-entity (car children) - (save-excursion - (set-buffer mime-raw-buffer) - mime-raw-message-info) - mime-raw-buffer (current-buffer) - default-situation - (if (= i p) - situation - (del-alist 'body-presentation-method - (copy-alist situation)))) + (let ((child (car children)) + (situation (car situations))) + (mime-display-entity child (if (= i p) + situation + (del-alist 'body-presentation-method + (copy-alist situation)))) ) (setq children (cdr children) situations (cdr situations) @@ -631,97 +562,58 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (setq entries (cdr entries)) ))) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . t)(subtype . t)(mode . "extract") -;; (method . mime-method-to-save))) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (mode . "play") + (method . mime-detect-content) + )) + (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 . plain)(mode . "play") -;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name) -;; )) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . text)(subtype . plain)(mode . "print") -;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name) -;; )) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . text)(subtype . html)(mode . "play") -;; (method "tm-html" nil 'file "" 'encoding 'mode 'name) -;; )) + (method . mime-save-content))) + (ctree-set-calist-strictly 'mime-acting-condition '((type . text)(subtype . x-rot13-47)(mode . "play") - (method . mime-method-to-display-caesar) + (method . mime-view-caesar) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . text)(subtype . x-rot13-47-48)(mode . "play") - (method . mime-method-to-display-caesar) + (method . mime-view-caesar) )) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . audio)(subtype . basic)(mode . "play") -;; (method "tm-au" nil 'file "" 'encoding 'mode 'name) -;; )) - -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . image)(mode . "play") -;; (method "tm-image" nil 'file "" 'encoding 'mode 'name) -;; )) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . image)(mode . "print") -;; (method "tm-image" nil 'file "" 'encoding 'mode 'name) -;; )) - -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . video)(subtype . mpeg)(mode . "play") -;; (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name) -;; )) - -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . application)(subtype . postscript)(mode . "play") -;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name) -;; )) -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . application)(subtype . postscript)(mode . "print") -;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name) -;; )) - (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . rfc822)(mode . "play") - (method . mime-method-to-display-message/rfc822) + (method . mime-view-message/rfc822) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . partial)(mode . "play") - (method . mime-method-to-store-message/partial) + (method . mime-store-message/partial-piece) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . external-body) ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) + (method . mime-view-message/external-anon-ftp) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("access-type" . "url") + (method . mime-view-message/external-url) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . application)(subtype . octet-stream) - (method . mime-method-to-save) + (method . mime-save-content) )) @@ -733,174 +625,76 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." . 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 ;;; -(defvar mime-view-following-method-alist nil +(defvar mime-preview-following-method-alist nil "Alist of major-mode vs. following-method of mime-view.") (defvar mime-view-following-required-fields-list '("From")) -;;; @ X-Face -;;; - -;; hack from Gnus 5.0.4. - -(defvar mime-view-x-face-to-pbm-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm") - -(defvar mime-view-x-face-command - (concat mime-view-x-face-to-pbm-command - " | xv -quit -") - "String to be executed to display an X-Face field. -The command will be executed in a sub-shell asynchronously. -The compressed face will be piped to this command.") - -(defun mime-view-x-face-function () - "Function to display X-Face field. You can redefine to customize." - ;; 1995/10/12 (c.f. tm-eng:130) - ;; fixed by Eric Ding - (save-restriction - (narrow-to-region (point-min) (re-search-forward "^$" nil t)) - ;; end - (goto-char (point-min)) - (if (re-search-forward "^X-Face:[ \t]*" nil t) - (let ((beg (match-end 0)) - (end (std11-field-end)) - ) - (call-process-region beg end "sh" nil 0 nil - "-c" mime-view-x-face-command) - )))) - - -;;; @ miscellaneous -;;; - -(defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode")) - - ;;; @ 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) - (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") - (mime-view-display-entity message-info message-info - the-buf obuf - '((entity-button . invisible) - (header . visible) - )) - (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 - default-situation - &optional situation) - (let* ((start (mime-entity-point-min entity)) - (end (mime-entity-point-max entity)) - (content-type (mime-entity-content-type entity)) - (encoding (mime-entity-encoding entity)) - end-of-header e nb ne subj) - (set-buffer ibuf) +(defun mime-display-entity (entity &optional situation + default-situation preview-buffer) + (or preview-buffer + (setq preview-buffer (current-buffer))) + (let* ((raw-buffer (mime-entity-buffer entity)) + (start (mime-entity-point-min entity)) + e nb ne) + (set-buffer raw-buffer) (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 start end) - (setq subj (eword-decode-string (mime-raw-get-subject entity))) - ) (or situation (setq situation (or (ctree-match-calist mime-preview-condition - (append - (or content-type - (make-mime-content-type - 'text 'plain)) - (list* (cons 'encoding encoding) - (cons 'major-mode major-mode) - default-situation))) + (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)) + (header-presentation-method + (or (cdr (assq 'header-presentation-method situation)) + (cdr (assq major-mode mime-header-presentation-method-alist)))) (body-presentation-method (cdr (assq 'body-presentation-method situation))) (children (mime-entity-children entity))) - (set-buffer obuf) + (set-buffer preview-buffer) (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 message-info subj) - )) - (if header-is-visible - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime-raw-buffer start end-of-header) - (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) + (mime-view-insert-entity-button entity) )) - (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 mime-raw-buffer end-of-header end) - (funcall body-filter situation) - ))) - (children) - ((functionp body-presentation-method) + (when header-is-visible + (if header-presentation-method + (funcall header-presentation-method entity situation) + (mime-insert-decoded-header entity + mime-view-ignored-field-list + mime-view-visible-field-list)) + (goto-char (point-max)) + (insert "\n") + (run-hooks 'mime-display-header-hook) + ) + (cond (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 message-info subj) + (mime-view-insert-entity-button entity) ) (or header-is-visible (progn @@ -910,45 +704,15 @@ The compressed face will be piped to this command.") )) (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) (if children (if (functionp body-presentation-method) (funcall body-presentation-method entity situation) - (mime-preview-multipart/mixed entity situation) + (mime-display-multipart/mixed entity situation) )) ))) -(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)) - "")) - ;;; @ MIME viewer mode ;;; @@ -963,7 +727,6 @@ The compressed face will be piped to this command.") (play "Play current entity" mime-preview-play-current-entity) (extract "Extract current entity" mime-preview-extract-current-entity) (print "Print current entity" mime-preview-print-current-entity) - (x-face "Show X Face" mime-preview-display-x-face) ) "Menu for MIME Viewer") @@ -1023,8 +786,6 @@ The compressed face will be piped to this command.") (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)) @@ -1086,7 +847,87 @@ The compressed face will be piped to this command.") (bury-buffer buf) )))) -(defun mime-view-mode (&optional mother ctl encoding ibuf obuf +(defvar mime-view-redisplay nil) + +(defun mime-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-preview-buffer preview-buffer) + (let ((inhibit-read-only t)) + (set-buffer (get-buffer-create 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-display-entity message nil + '((entity-button . invisible) + (header . visible)) + preview-buffer) + (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) + (or (get-buffer-window preview-buffer) + (let ((r-win (get-buffer-window raw-buffer))) + (if r-win + (set-window-buffer r-win preview-buffer) + (let ((m-win (and mother (get-buffer-window mother)))) + (if m-win + (set-window-buffer m-win preview-buffer) + (switch-to-buffer preview-buffer) + ))))) + ))) + +(defun mime-view-buffer (&optional raw-buffer preview-buffer mother + default-keymap-or-function + representation-type) + "View RAW-BUFFER in MIME-View mode. +Optional argument PREVIEW-BUFFER is either nil or a name of preview +buffer. +Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or +function. If it is a keymap, keymap of MIME-View mode will be added +to it. If it is a function, it will be bound as default binding of +keymap of MIME-View mode. +Optional argument REPRESENTATION-TYPE is representation-type of +message. It must be nil, `binary' or `cooked'. If it is nil, +`binary' is used as default." + (interactive) + (or raw-buffer + (setq raw-buffer (current-buffer))) + (or representation-type + (setq representation-type + (save-excursion + (set-buffer raw-buffer) + (cdr (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))) + ))) + (if (eq representation-type 'binary) + (setq representation-type 'buffer) + ) + (mime-display-message + (mime-open-entity representation-type raw-buffer) + 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. @@ -1106,33 +947,32 @@ 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)) + (unless mime-view-redisplay + (save-excursion + (if raw-buffer (set-buffer raw-buffer)) + (let ((type + (cdr + (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))))) + (if (eq type 'binary) + (setq type 'buffer) + ) + (setq mime-message-structure (mime-open-entity type raw-buffer)) + (or (mime-entity-content-type mime-message-structure) + (mime-entity-set-content-type-internal + mime-message-structure ctl)) ) - (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) - ))) + (or (mime-entity-encoding mime-message-structure) + (mime-entity-set-encoding-internal mime-message-structure encoding)) + )) + (mime-display-message mime-message-structure preview-buffer + mother default-keymap-or-function) + ) ;;; @@ playing @@ -1141,43 +981,32 @@ button-2 Move to point under the mouse cursor (autoload 'mime-preview-play-current-entity "mime-play" "Play current entity." t) -(defun mime-preview-extract-current-entity () +(defun mime-preview-extract-current-entity (&optional ignore-examples) "Extract current entity into file (maybe). It decodes current entity to call internal or external method as \"extract\" mode. The method is selected from variable `mime-acting-condition'." - (interactive) - (mime-preview-play-current-entity "extract") + (interactive "P") + (mime-preview-play-current-entity ignore-examples "extract") ) -(defun mime-preview-print-current-entity () +(defun mime-preview-print-current-entity (&optional ignore-examples) "Print current entity (maybe). It decodes current entity to call internal or external method as \"print\" mode. The method is selected from variable `mime-acting-condition'." - (interactive) - (mime-preview-play-current-entity "print") + (interactive "P") + (mime-preview-play-current-entity ignore-examples "print") ) ;;; @@ 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'." +`mime-preview-following-method-alist'." (interactive) (let (entity) (while (null (setq entity @@ -1230,7 +1059,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 @@ -1248,9 +1077,8 @@ It calls following-method selected from variable str (save-excursion (set-buffer a-buf) - (setq - ci - (mime-raw-find-entity-from-node-id entity-node-id)) + (setq ci + (mime-find-entity-from-node-id entity-node-id)) (save-restriction (narrow-to-region (mime-entity-point-min ci) @@ -1292,7 +1120,7 @@ It calls following-method selected from variable )) (eword-decode-header) ) - (let ((f (cdr (assq mode mime-view-following-method-alist)))) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) (if (functionp f) (funcall f new-buf) (message @@ -1303,17 +1131,6 @@ It calls following-method selected from variable )))) -;;; @@ X-Face -;;; - -(defun mime-preview-display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime-raw-buffer) - (mime-view-x-face-function) - )) - - ;;; @@ moving ;;; @@ -1326,9 +1143,7 @@ If there is no upper entity, call function `mime-preview-quit'." (get-text-property (point) 'mime-view-entity))) (backward-char) ) - (let ((r (mime-raw-find-entity-from-node-id - (cdr (mime-entity-node-id cinfo)) - (get-text-property 1 'mime-view-entity))) + (let ((r (mime-entity-parent cinfo)) point) (catch 'tag (while (setq point (previous-single-property-change @@ -1344,7 +1159,7 @@ 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) @@ -1356,8 +1171,8 @@ variable `mime-view-over-to-previous-method-alist'." (goto-char (1- point)) (mime-preview-move-to-previous) ) - (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)) )) @@ -1366,7 +1181,7 @@ 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) @@ -1378,8 +1193,8 @@ variable `mime-view-over-to-next-method-alist'." (if (null (get-text-property point 'mime-view-entity)) (mime-preview-move-to-next) )) - (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)) )) @@ -1388,14 +1203,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)) )) @@ -1411,30 +1226,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 (not (bobp)) - (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) @@ -1459,23 +1264,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))