X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=mime-view.el;h=9e686981acb88597876034c9d3fabcbabb9014e8;hb=2d6815498c15cd57432a750e9894e88ffc2c08f5;hp=19b2c5f007bf55270fff1ae5b460744398866ddb;hpb=5ca0e06429861149372d2e3b4bab3cabac529d70;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index 19b2c5f..9e68698 100644 --- a/mime-view.el +++ b/mime-view.el @@ -1,6 +1,6 @@ ;;; mime-view.el --- interactive MIME viewer for GNU Emacs -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1994/07/13 @@ -8,7 +8,7 @@ ;; Renamed: 1997/02/19 from tm-view.el ;; Keywords: MIME, multimedia, mail, news -;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces). +;; This file is part of SEMI (Sample of Elastic MIME Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -27,8 +27,8 @@ ;;; Code: -(require 'std11) -(require 'mime-lib) +(require 'emu) +(require 'mime) (require 'semi-def) (require 'calist) (require 'alist) @@ -38,11 +38,11 @@ ;;; @ version ;;; -(defconst mime-view-version-string - `,(concat (car mime-user-interface-version) " MIME-View " - (mapconcat #'number-to-string - (cddr mime-user-interface-version) ".") - " (" (cadr mime-user-interface-version) ")")) +(defconst mime-view-version + (concat (mime-product-name mime-user-interface-product) " MIME-View " + (mapconcat #'number-to-string + (mime-product-version mime-user-interface-product) ".") + " (" (mime-product-code-name mime-user-interface-product) ")")) ;;; @ variables @@ -71,16 +71,6 @@ (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) @@ -89,53 +79,28 @@ 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.") - - -(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-message-structure' 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-message-structure' is used." - (or message-info - (setq message-info mime-message-structure)) - (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-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)))) +`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)))) +;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.") ;;; @ in preview-buffer (presentation space) @@ -147,15 +112,15 @@ If current MIME-preview buffer is generated by other buffer, such as message/partial, it is called `mother-buffer'.") (make-variable-buffer-local 'mime-mother-buffer) -(defvar mime-raw-buffer nil - "Raw buffer corresponding with the (MIME-preview) buffer.") -(make-variable-buffer-local 'mime-raw-buffer) +;; (defvar mime-raw-buffer nil +;; "Raw buffer corresponding with the (MIME-preview) buffer.") +;; (make-variable-buffer-local 'mime-raw-buffer) (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) +(defun mime-preview-original-major-mode (&optional recursive point) "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 @@ -165,91 +130,94 @@ mother-buffer." (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))) + (cdr (assq 'major-mode + (get-text-property (or point (point)) 'mime-view-situation))))) ;;; @ entity information ;;; -(defsubst mime-entity-parent (entity &optional message-info) - "Return mother entity of ENTITY. -If optional argument MESSAGE-INFO is not specified, -`mime-message-structure' 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-message-structure)))) - -(defun mime-entity-situation (entity) +(defun mime-entity-situation (entity &optional situation) "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-entity-uu-filename (entity) - (if (member (mime-entity-encoding entity) - mime-view-uuencode-encoding-name-list) - (save-excursion - (set-buffer (mime-entity-buffer entity)) - (goto-char (mime-entity-body-start entity)) - (if (re-search-forward "^begin [0-9]+ " - (mime-entity-body-end entity) t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - ))))) - -(defun mime-entity-filename (entity) - (or (mime-entity-uu-filename entity) - (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) - )) - )) + (let (rest param name) + ;; Content-Type + (unless (assq 'type situation) + (setq rest (or (mime-entity-content-type entity) + (make-mime-content-type 'text 'plain)) + situation (cons (car rest) situation) + rest (cdr rest)) + ) + (unless (assq 'subtype situation) + (or rest + (setq rest (or (cdr (mime-entity-content-type entity)) + '((subtype . plain))))) + (setq situation (cons (car rest) situation) + rest (cdr rest)) + ) + (while rest + (setq param (car rest)) + (or (assoc (car param) situation) + (setq situation (cons param situation))) + (setq rest (cdr rest))) + + ;; Content-Disposition + (setq rest nil) + (unless (assq 'disposition-type situation) + (setq rest (mime-entity-content-disposition entity)) + (if rest + (setq situation (cons (cons 'disposition-type + (mime-content-disposition-type rest)) + situation) + rest (mime-content-disposition-parameters rest)) + )) + (while rest + (setq param (car rest) + name (car param)) + (if (cond ((string= name "filename") + (if (assq 'filename situation) + nil + (setq name 'filename))) + ((string= name "creation-date") + (if (assq 'creation-date situation) + nil + (setq name 'creation-date))) + ((string= name "modification-date") + (if (assq 'modification-date situation) + nil + (setq name 'modification-date))) + ((string= name "read-date") + (if (assq 'read-date situation) + nil + (setq name 'read-date))) + ((string= name "size") + (if (assq 'size situation) + nil + (setq name 'size))) + (t (setq name (cons 'disposition name)) + (if (assoc name situation) + nil + name))) + (setq situation + (cons (cons name (cdr param)) + situation))) + (setq rest (cdr rest))) + + ;; Content-Transfer-Encoding + (or (assq 'encoding situation) + (setq situation + (cons (cons 'encoding (or (mime-entity-encoding entity) + "7bit")) + situation))) + + ;; major-mode + ;; (or (assq 'major-mode situation) + ;; (setq situation + ;; (cons (cons 'major-mode + ;; (with-current-buffer (mime-entity-buffer entity) + ;; major-mode)) + ;; situation))) + + situation)) (defun mime-view-entity-title (entity) (or (mime-entity-read-field entity 'Content-Description) @@ -258,30 +226,34 @@ If optional argument MESSAGE-INFO is not specified, "")) -(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-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-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-message-structure' is used." - (or message-info - (setq message-info mime-message-structure)) - (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)) +;; (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-message-structure' is used." +;; (mime-entity-node-id (mime-raw-find-entity-from-point point message-info))) + +;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.") + +;; (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-message-structure' is used." +;; (mime-entity-number (mime-raw-find-entity-from-point point message-info))) + +;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.") + +;; (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-message-structure' is used." +;; (or message-info +;; (setq message-info mime-message-structure)) +;; (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 @@ -336,9 +308,13 @@ Please redefine this function if you want to change default setting." num subject access-type (cdr server)) (let ((site (cdr (assoc "site" params))) (dir (cdr (assoc "directory" params))) + (url (cdr (assoc "url" params))) ) - (format "%s %s ([%s] %s:%s)" - num subject access-type site dir) + (if url + (format "%s %s ([%s] %s)" + num subject access-type url) + (format "%s %s ([%s] %s:%s)" + num subject access-type site dir)) ))) ) (t @@ -375,15 +351,15 @@ 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" - "Replied" "Errors-To" - "Lines" "Sender" ".*Host" "Xref" - "Content-Type" "Precedence" - "Status" "X-VM-.*") + '(".*Received:" ".*Path:" ".*Id:" "^References:" + "^Replied:" "^Errors-To:" + "^Lines:" "^Sender:" ".*Host:" "^Xref:" + "^Content-Type:" "^Precedence:" + "^Status:" "^X-VM-.*:") "All fields that match this list will be hidden in MIME preview buffer. Each elements are regexp of field-name.") -(defvar mime-view-visible-field-list '("Dnas.*" "Message-Id") +(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.") @@ -394,6 +370,8 @@ Each elements are regexp of field-name.") ;;; @@@ predicate function ;;; +(in-calist-package 'mime-view) + (defun mime-calist::field-match-method-as-default-rule (calist field-type field-value) (let ((s-field (assq field-type calist))) @@ -501,9 +479,38 @@ Each elements are regexp of field-name.") ;;; @@@ entity presentation ;;; -(autoload 'mime-display-text/plain "mime-text") -(autoload 'mime-display-text/enriched "mime-text") -(autoload 'mime-display-text/richtext "mime-text") +(defun mime-display-text/plain (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (goto-char (point-max)) + (if (not (eq (char-after (1- (point))) ?\n)) + (insert "\n") + ) + (mime-add-url-buttons) + (run-hooks 'mime-display-text/plain-hook) + )) + +(defun mime-display-text/richtext (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (richtext-decode beg (point-max)) + ))) + +(defun mime-display-text/enriched (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (enriched-decode beg (point-max)) + ))) (defvar mime-view-announcement-for-message/partial (if (and (>= emacs-major-version 19) window-system) @@ -531,8 +538,14 @@ Each elements are regexp of field-name.") (defun mime-display-multipart/mixed (entity situation) (let ((children (mime-entity-children entity)) + (original-major-mode (cdr (assq 'major-mode situation))) (default-situation (cdr (assq 'childrens-situation situation)))) + (if original-major-mode + (setq default-situation + (cons (cons 'major-mode original-major-mode) + default-situation)) + ) (while children (mime-display-entity (car children) nil default-situation) (setq children (cdr children)) @@ -547,20 +560,28 @@ 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-display-multipart/alternative (entity situation) (let* ((children (mime-entity-children entity)) + (original-major-mode (cdr (assq 'major-mode situation))) (default-situation (cdr (assq 'childrens-situation situation))) (i 0) (p 0) (max-score 0) - (situations + situations) + (if original-major-mode + (setq default-situation + (cons (cons 'major-mode original-major-mode) + default-situation)) + ) + (setq situations (mapcar (function (lambda (child) (let ((situation @@ -591,7 +612,7 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (setq i (1+ i)) situation) )) - children))) + children)) (setq i 0) (while children (let ((child (car children)) @@ -680,7 +701,14 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." 'mime-acting-condition '((type . message)(subtype . external-body) ("access-type" . "anon-ftp") - (method . mime-view-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 @@ -715,38 +743,6 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." '("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) - )))) - - ;;; @ buffer setup ;;; @@ -754,11 +750,9 @@ The compressed face will be piped to this command.") 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) + (let* (e nb ne nhb nbb) + (mime-goto-header-start-point entity) + (in-calist-package 'mime-view) (or situation (setq situation (or (ctree-match-calist mime-preview-condition @@ -783,21 +777,18 @@ The compressed face will be piped to this command.") (mime-view-insert-entity-button entity) )) (when header-is-visible + (setq nhb (point)) (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 - (save-excursion - (set-buffer raw-buffer) - (if (eq (cdr (assq major-mode mime-raw-representation-type-alist)) - 'binary) - default-mime-charset) - ))) + (mime-insert-header entity + mime-view-ignored-field-list + mime-view-visible-field-list)) + (run-hooks 'mime-display-header-hook) + (put-text-property nhb (point-max) 'mime-view-entity-header entity) (goto-char (point-max)) (insert "\n") - (run-hooks 'mime-display-header-hook) ) + (setq nbb (point)) (cond (children) ((functionp body-presentation-method) (funcall body-presentation-method entity situation) @@ -816,6 +807,8 @@ The compressed face will be piped to this command.") (setq ne (point-max)) (widen) (put-text-property nb ne 'mime-view-entity entity) + (put-text-property nb ne 'mime-view-situation situation) + (put-text-property nbb ne 'mime-view-entity-body entity) (goto-char ne) (if children (if (functionp body-presentation-method) @@ -838,11 +831,10 @@ 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") -(cond (running-xemacs +(cond ((featurep 'xemacs) (defvar mime-view-xemacs-popup-menu (cons mime-view-menu-title (mapcar (function @@ -912,7 +904,7 @@ The compressed face will be piped to this command.") (define-key mime-view-mode-map [backspace] (function mime-preview-scroll-down-entity)) (if (functionp default) - (cond (running-xemacs + (cond ((featurep 'xemacs) (set-keymap-default-binding mime-view-mode-map default) ) (t @@ -923,7 +915,7 @@ The compressed face will be piped to this command.") (define-key mime-view-mode-map mouse-button-2 (function mime-button-dispatcher)) ) - (cond (running-xemacs + (cond ((featurep 'xemacs) (define-key mime-view-mode-map mouse-button-3 (function mime-view-xemacs-popup-menu)) ) @@ -961,22 +953,34 @@ The compressed face will be piped to this command.") (defvar mime-view-redisplay nil) +;;;###autoload (defun mime-display-message (message &optional preview-buffer - mother default-keymap-or-function) + mother default-keymap-or-function + original-major-mode) + "View MESSAGE in MIME-View mode. + +Optional argument PREVIEW-BUFFER specifies the buffer of the +presentation. It must be either nil or a name of preview buffer. + +Optional argument MOTHER specifies mother-buffer of the 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." (mime-maybe-hide-echo-buffer) - (let ((win-conf (current-window-configuration)) - (raw-buffer (mime-entity-buffer message))) + (let ((win-conf (current-window-configuration))) (or preview-buffer (setq preview-buffer - (concat "*Preview-" (buffer-name raw-buffer) "*"))) - (set-buffer raw-buffer) - (mime-parse-buffer) - (setq mime-preview-buffer preview-buffer) + (concat "*Preview-" (mime-entity-name message) "*"))) + (or original-major-mode + (setq original-major-mode + (with-current-buffer (mime-entity-header-buffer message) + major-mode))) (let ((inhibit-read-only t)) - (switch-to-buffer preview-buffer) + (set-buffer (get-buffer-create preview-buffer)) (widen) (erase-buffer) - (setq mime-raw-buffer raw-buffer) (if mother (setq mime-mother-buffer mother) ) @@ -984,8 +988,9 @@ The compressed face will be piped to this command.") (setq major-mode 'mime-view-mode) (setq mode-name "MIME-View") (mime-display-entity message nil - '((entity-button . invisible) - (header . visible)) + `((entity-button . invisible) + (header . visible) + (major-mode . ,original-major-mode)) preview-buffer) (mime-view-define-keymap default-keymap-or-function) (let ((point @@ -996,20 +1001,49 @@ The compressed face will be piped to this command.") (search-forward "\n\n" nil t) )) (run-hooks 'mime-view-mode-hook) - )) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - ) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + preview-buffer))) +;;;###autoload (defun mime-view-buffer (&optional raw-buffer preview-buffer mother - default-keymap-or-function) + 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, +`cooked' is used as default." (interactive) - (mime-display-message - (save-excursion - (if raw-buffer (set-buffer raw-buffer)) - (mime-parse-message) - ) - preview-buffer mother default-keymap-or-function)) + (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) + ) + (setq preview-buffer (mime-display-message + (mime-open-entity representation-type raw-buffer) + preview-buffer mother default-keymap-or-function)) + (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-mode (&optional mother ctl encoding raw-buffer preview-buffer @@ -1037,13 +1071,27 @@ button-2 Move to point under the mouse cursor and decode current content as `play mode' " (interactive) - (mime-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)) + (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)) + ) + (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 @@ -1052,22 +1100,22 @@ 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") ) @@ -1087,6 +1135,7 @@ It calls following-method selected from variable (let* ((p-beg (previous-single-property-change (point) 'mime-view-entity)) p-end + ph-end (entity-node-id (mime-entity-node-id entity)) (len (length entity-node-id)) ) @@ -1130,17 +1179,26 @@ It calls following-method selected from variable (setq p-end (point-max)) )) )) + (setq ph-end + (previous-single-property-change p-end 'mime-view-entity-header)) + (if (or (null ph-end) + (< ph-end p-beg)) + (setq ph-end p-beg) + ) (let* ((mode (mime-preview-original-major-mode 'recursive)) (new-name (format "%s-%s" (buffer-name) (reverse entity-node-id))) new-buf (the-buf (current-buffer)) - (a-buf mime-raw-buffer) + (a-buf (mime-entity-buffer entity)) fields) (save-excursion (set-buffer (setq new-buf (get-buffer-create new-name))) (erase-buffer) - (insert-buffer-substring the-buf p-beg p-end) + (insert-buffer-substring the-buf ph-end p-end) + (when (= ph-end p-beg) + (goto-char (point-min)) + (insert ?\n)) (goto-char (point-min)) (let ((entity-node-id (mime-entity-node-id entity)) ci str) (while (progn @@ -1148,9 +1206,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) @@ -1160,9 +1217,8 @@ It calls following-method selected from variable (concat "^" (apply (function regexp-or) fields) ":") "")))) - (if (and - (eq (mime-entity-media-type ci) 'message) - (eq (mime-entity-media-subtype ci) 'rfc822)) + (if (and (eq (mime-entity-media-type ci) 'message) + (eq (mime-entity-media-subtype ci) 'rfc822)) nil (if str (insert str) @@ -1190,7 +1246,7 @@ It calls following-method selected from variable )) (setq rest (cdr rest)) )) - (eword-decode-header) + (mime-decode-header-in-buffer) ) (let ((f (cdr (assq mode mime-preview-following-method-alist)))) (if (functionp f) @@ -1203,17 +1259,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 ;;; @@ -1226,9 +1271,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 @@ -1268,7 +1311,8 @@ variable `mime-preview-over-to-previous-method-alist'." If there is no previous entity, it calls function registered in variable `mime-preview-over-to-next-method-alist'." (interactive) - (while (null (get-text-property (point) 'mime-view-entity)) + (while (and (not (eobp)) + (null (get-text-property (point) 'mime-view-entity))) (forward-char) ) (let ((point (next-single-property-change (point) 'mime-view-entity)))