X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=21819051a8f1d05b6bed05e2cfccd0d6519ff834;hb=b2398720282867dd778a1fe6ee4d63fd3674e757;hp=fb9577800e5cc0afed9274e654fc1e33728a969a;hpb=d54dd3c08fa3d6354a36471a49438909c6762125;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index fb9577800..21819051a 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,5 +1,5 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -27,15 +27,20 @@ (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl) + (require 'term)) (eval-and-compile (autoload 'mm-inline-partial "mm-partial") - (autoload 'mm-inline-external-body "mm-extern")) + (autoload 'mm-inline-external-body "mm-extern") + (autoload 'mm-insert-inline "mm-view")) + +(add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) (defgroup mime-display () "Display of MIME in mail and news articles." :link '(custom-manual "(emacs-mime)Customization") + :version "21.1" :group 'mail :group 'news :group 'multimedia) @@ -79,6 +84,8 @@ `(nth 7 ,handle)) (defmacro mm-handle-multipart-original-buffer (handle) `(get-text-property 0 'buffer (car ,handle))) +(defmacro mm-handle-multipart-from (handle) + `(get-text-property 0 'from (car ,handle))) (defmacro mm-handle-multipart-ctl-parameter (handle parameter) `(get-text-property 0 ,parameter (car ,handle))) @@ -88,6 +95,20 @@ `(list ,buffer ,type ,encoding ,undisplayer ,disposition ,description ,cache ,id)) +(defcustom mm-inline-text-html-renderer + (cond ((locate-library "w3") + 'mm-inline-text-html-render-with-w3) + ((locate-library "w3m") + 'mm-inline-text-html-render-with-w3m)) + "Function used for rendering HTML contents. The function will be +called with a MIME handle as the argument. There are two pre-defined +functions: `mm-inline-text-html-render-with-w3', which uses Emacs/w3; +and `mm-inline-text-html-render-with-w3m', which uses emacs-w3m." + :type '(radio (function-item mm-inline-text-html-render-with-w3) + (function-item mm-inline-text-html-render-with-w3m) + (function)) + :group 'mime-display) + (defcustom mm-inline-media-tests '(("image/jpeg" mm-inline-image @@ -125,6 +146,10 @@ mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'bmp handle))) + ("image/x-portable-bitmap" + mm-inline-image + (lambda (handle) + (mm-valid-and-fit-image-p 'pbm handle))) ("text/plain" mm-inline-text identity) ("text/enriched" mm-inline-text identity) ("text/richtext" mm-inline-text identity) @@ -132,10 +157,11 @@ (lambda (handle) (locate-library "diff-mode"))) ("application/emacs-lisp" mm-display-elisp-inline identity) + ("application/x-emacs-lisp" mm-display-elisp-inline identity) ("text/html" mm-inline-text (lambda (handle) - (locate-library "w3"))) + (gnus-functionp mm-inline-text-html-renderer))) ("text/x-vcard" mm-inline-text (lambda (handle) @@ -158,9 +184,16 @@ ("application/pgp-signature" ignore identity) ("application/x-pkcs7-signature" ignore identity) ("application/pkcs7-signature" ignore identity) + ("application/x-pkcs7-mime" ignore identity) + ("application/pkcs7-mime" ignore identity) ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) - ("multipart/related" ignore identity)) + ("multipart/related" ignore identity) + ;; Disable audio and image + ("audio/.*" ignore ignore) + ("image/.*" ignore ignore) + ;; Default to displaying as text + (".*" mm-inline-text mm-readable-p)) "Alist of media types/tests saying whether types can be displayed inline." :type '(repeat (list (string :tag "MIME type") (function :tag "Display function") @@ -171,22 +204,38 @@ '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" "message/partial" "message/external-body" "application/emacs-lisp" "application/pgp-signature" "application/x-pkcs7-signature" - "application/pkcs7-signature") - "List of media types that are to be displayed inline." + "application/pkcs7-signature" "application/x-pkcs7-mime" + "application/pkcs7-mime") + "List of media types that are to be displayed inline. +See also `mm-inline-media-tests', which says how to display a media +type inline." :type '(repeat string) :group 'mime-display) - + +(defcustom mm-keep-viewer-alive-types + '("application/postscript" "application/msword" "application/vnd.ms-excel" + "application/pdf" "application/x-dvi") + "List of media types for which the external viewer will not be killed +when selecting a different article." + :type '(repeat string) + :group 'mime-display) + (defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" "message/rfc822" "text/x-patch" "application/pgp-signature" "application/emacs-lisp" "application/x-pkcs7-signature" - "application/pkcs7-signature") + "application/pkcs7-signature" "application/x-pkcs7-mime" + "application/pkcs7-mime") "A list of MIME types to be displayed automatically." :type '(repeat string) :group 'mime-display) -(defcustom mm-attachment-override-types '("text/x-vcard") +(defcustom mm-attachment-override-types '("text/x-vcard" + "application/pkcs7-mime" + "application/x-pkcs7-mime" + "application/pkcs7-signature" + "application/x-pkcs7-signature") "Types to have \"attachment\" ignored if they can be displayed inline." :type '(repeat string) :group 'mime-display) @@ -214,22 +263,59 @@ to: :type '(repeat string) :group 'mime-display) -(defvar mm-tmp-directory +(defcustom mm-tmp-directory (cond ((fboundp 'temp-directory) (temp-directory)) ((boundp 'temporary-file-directory) temporary-file-directory) ("/tmp/")) - "Where mm will store its temporary files.") + "Where mm will store its temporary files." + :type 'directory + :group 'mime-display) (defcustom mm-inline-large-images nil "If non-nil, then all images fit in the buffer." :type 'boolean :group 'mime-display) +(defvar mm-file-name-rewrite-functions nil + "*List of functions used for rewriting file names of MIME parts. +Each function takes a file name as input and returns a file name. + +Ready-made functions include +`mm-file-name-delete-whitespace', +`mm-file-name-trim-whitespace', +`mm-file-name-collapse-whitespace', +`mm-file-name-replace-whitespace', +`capitalize', `downcase', `upcase', and +`upcase-initials'.") + +(defvar mm-path-name-rewrite-functions nil + "*List of functions used for rewriting path names of MIME parts. +This is used when viewing parts externally , and is meant for +transforming the path name so that non-compliant programs can +find the file where it's saved. + +Each function takes a file name as input and returns a file name.") + +(defvar mm-file-name-replace-whitespace nil + "String used for replacing whitespace characters; default is `\"_\"'.") + +(defcustom mm-default-directory nil + "The default directory where mm will save files. +If not set, `default-directory' will be used." + :type '(choice directory (const :tag "Default" nil)) + :group 'mime-display) + +(defcustom mm-external-terminal-program "xterm" + "The program to start an external terminal." + :type 'string + :group 'mime-display) + ;;; Internal variables. (defvar mm-dissection-list nil) (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) +(defvar mm-postponed-undisplay-list nil) ;; According to RFC2046, in particular, in a digest, the default ;; Content-Type value for a body part is changed from "text/plain" to @@ -243,14 +329,16 @@ to: (defvar mm-verify-function-alist '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test) - ("application/pkcs7-signature" mml-smime-verify "S/MIME" + ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP" + mm-uu-pgp-signed-test) + ("application/pkcs7-signature" mml-smime-verify "S/MIME" mml-smime-verify-test) - ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" + ("application/x-pkcs7-signature" mml-smime-verify "S/MIME" mml-smime-verify-test))) -(defcustom mm-verify-option nil +(defcustom mm-verify-option 'never "Option of verifying signed parts. -`never', not verify; `always', always verify; +`never', not verify; `always', always verify; `known', only verify known protocols. Otherwise, ask user." :type '(choice (item always) (item never) @@ -262,11 +350,13 @@ to: (autoload 'mml2015-decrypt-test "mml2015") (defvar mm-decrypt-function-alist - '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test))) + '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test) + ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP" + mm-uu-pgp-encrypted-test))) (defcustom mm-decrypt-option nil - "Option of decrypting signed parts. -`never', not decrypt; `always', always decrypt; + "Option of decrypting encrypted parts. +`never', not decrypt; `always', always decrypt; `known', only decrypt known protocols. Otherwise, ask user." :type '(choice (item always) (item never) @@ -281,7 +371,16 @@ to: "Keymap for input viewer with completion.") ;; Should we bind other key to minibuffer-complete-word? -(define-key mm-viewer-completion-map " " 'self-insert-command) +(define-key mm-viewer-completion-map " " 'self-insert-command) + +(defvar mm-viewer-completion-map + (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) + (set-keymap-parent map minibuffer-local-completion-map) + map) + "Keymap for input viewer with completion.") + +;; Should we bind other key to minibuffer-complete-word? +(define-key mm-viewer-completion-map " " 'self-insert-command) ;;; The functions. @@ -303,10 +402,35 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (setq alist (cdr alist))) (nreverse plist))) +(defun mm-keep-viewer-alive-p (handle) + "Say whether external viewer for HANDLE should stay alive." + (let ((types mm-keep-viewer-alive-types) + (type (mm-handle-media-type handle)) + ty) + (catch 'found + (while (setq ty (pop types)) + (when (string-match ty type) + (throw 'found t)))))) + +(defun mm-handle-set-external-undisplayer (handle function) + "Set the undisplayer for this handle; postpone undisplaying of viewers +for types in mm-keep-viewer-alive-types." + (if (mm-keep-viewer-alive-p handle) + (let ((new-handle (copy-sequence handle))) + (mm-handle-set-undisplayer new-handle function) + (mm-handle-set-undisplayer handle nil) + (push new-handle mm-postponed-undisplay-list)) + (mm-handle-set-undisplayer handle function))) + +(defun mm-destroy-postponed-undisplay-list () + (when mm-postponed-undisplay-list + (message "Destroying external MIME viewers") + (mm-destroy-parts mm-postponed-undisplay-list))) + (defun mm-dissect-buffer (&optional no-strict-mime) "Dissect the current buffer and return a list of MIME handles." (save-excursion - (let (ct ctl type subtype cte cd description id result) + (let (ct ctl type subtype cte cd description id result from) (save-restriction (mail-narrow-to-head) (when (or no-strict-mime @@ -316,7 +440,14 @@ The original alist is not modified. See also `destructive-alist-to-plist'." cte (mail-fetch-field "content-transfer-encoding") cd (mail-fetch-field "content-disposition") description (mail-fetch-field "content-description") - id (mail-fetch-field "content-id")))) + from (mail-fetch-field "from") + id (mail-fetch-field "content-id")) + ;; FIXME: In some circumstances, this code is running within + ;; an unibyte macro. mail-extract-address-components + ;; creates unibyte buffers. This `if', though not a perfect + ;; solution, avoids most of them. + (if from + (setq from (cadr (mail-extract-address-components from)))))) (when cte (setq cte (mail-header-strip cte))) (if (or (not ctl) @@ -339,27 +470,33 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (let ((mm-dissect-default-type (if (equal subtype "digest") "message/rfc822" "text/plain"))) - (add-text-properties 0 (length (car ctl)) - (mm-alist-to-plist (cdr ctl)) (car ctl)) + (add-text-properties 0 (length (car ctl)) + (mm-alist-to-plist (cdr ctl)) (car ctl)) ;; what really needs to be done here is a way to link a ;; MIME handle back to it's parent MIME handle (in a multilevel ;; MIME article). That would probably require changing ;; the mm-handle API so we simply store the multipart buffert ;; name as a text property of the "multipart/whatever" string. - (add-text-properties 0 (length (car ctl)) + (add-text-properties 0 (length (car ctl)) (list 'buffer (mm-copy-to-buffer)) - (car ctl)) + (car ctl)) + (add-text-properties 0 (length (car ctl)) + (list 'from from) + (car ctl)) (cons (car ctl) (mm-dissect-multipart ctl)))) (t - (mm-dissect-singlepart - ctl - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) - no-strict-mime - (and cd (ignore-errors (mail-header-parse-content-disposition cd))) - description id)))) + (mm-possibly-verify-or-decrypt + (mm-dissect-singlepart + ctl + (and cte (intern (downcase (mail-header-remove-whitespace + (mail-header-remove-comments + cte))))) + no-strict-mime + (and cd (ignore-errors + (mail-header-parse-content-disposition cd))) + description id) + ctl)))) (when id (when (string-match " *<\\(.*\\)> *" id) (setq id (match-string 1 id))) @@ -393,7 +530,7 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (match-beginning 0) (point-max))))) (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) - (while (re-search-forward boundary end t) + (while (and (< (point) end) (re-search-forward boundary end t)) (goto-char (match-beginning 0)) (when start (save-excursion @@ -402,7 +539,7 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) (forward-line 2) (setq start (point))) - (when start + (when (and start (< start end)) (save-excursion (save-restriction (narrow-to-region start end) @@ -441,7 +578,8 @@ external if displayed external." (mm-remove-part handle) (let* ((type (mm-handle-media-type handle)) (method (mailcap-mime-info type))) - (if (mm-inlined-p handle) + (if (and (mm-inlinable-p handle) + (mm-inlined-p handle)) (progn (forward-line 1) (mm-display-inline handle) @@ -490,9 +628,13 @@ external if displayed external." (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) - (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory))) - (filename (mail-content-type-get - (mm-handle-disposition handle) 'filename)) + (let* ((dir (make-temp-name + (expand-file-name "emm." mm-tmp-directory))) + (filename (or + (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name))) (mime-info (mailcap-mime-info (mm-handle-media-type handle) t)) (needsterm (or (assoc "needsterm" mime-info) @@ -509,54 +651,77 @@ external if displayed external." (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) (message "Viewing with %s" method) - (cond (needsterm - (unwind-protect - (start-process "*display*" nil - "xterm" - "-e" shell-file-name - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (mm-handle-set-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)) - 'external) - (copiousoutput - (with-current-buffer outbuf - (forward-line 1) - (mm-insert-inline - handle - (unwind-protect - (progn - (call-process shell-file-name nil - (setq buffer - (generate-new-buffer " *mm*")) - nil - shell-command-switch - (mm-mailcap-command - method file (mm-handle-type handle))) - (if (buffer-live-p buffer) - (save-excursion - (set-buffer buffer) - (buffer-string)))) - (progn - (ignore-errors (delete-file file)) - (ignore-errors (delete-directory - (file-name-directory file))) - (ignore-errors (kill-buffer buffer)))))) - 'inline) - (t - (unwind-protect - (start-process "*display*" - (setq buffer - (generate-new-buffer " *mm*")) + (cond + (needsterm + (unwind-protect + (if window-system + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (require 'term) + (require 'gnus-win) + (set-buffer + (setq buffer + (make-term "display" shell-file-name + nil shell-command-switch (mm-mailcap-command - method file (mm-handle-type handle))) - (mm-handle-set-undisplayer handle (cons file buffer))) - (message "Displaying %s..." (format method file)) - 'external))))))) - + method file + (mm-handle-type handle))))) + (term-mode) + (term-char-mode) + (set-process-sentinel + (get-buffer-process buffer) + `(lambda (process state) + (if (eq 'exit (process-status process)) + (gnus-configure-windows + ',gnus-current-window-configuration)))) + (gnus-configure-windows 'display-term)) + (mm-handle-set-external-undisplayer handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external) + (copiousoutput + (with-current-buffer outbuf + (forward-line 1) + (mm-insert-inline + handle + (unwind-protect + (progn + (call-process shell-file-name nil + (setq buffer + (generate-new-buffer " *mm*")) + nil + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (if (buffer-live-p buffer) + (save-excursion + (set-buffer buffer) + (buffer-string)))) + (progn + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))) + (ignore-errors (kill-buffer buffer)))))) + 'inline) + (t + (unwind-protect + (start-process "*display*" + (setq buffer + (generate-new-buffer " *mm*")) + shell-file-name + shell-command-switch + (mm-mailcap-command + method file (mm-handle-type handle))) + (mm-handle-set-external-undisplayer + handle (cons file buffer))) + (message "Displaying %s..." (format method file)) + 'external))))))) + (defun mm-mailcap-command (method file type-list) (let ((ctl (cdr type-list)) (beg 0) @@ -572,16 +737,18 @@ external if displayed external." (push "%" out)) ((string= total "%s") (setq uses-stdin nil) - (push (mm-quote-arg file) out)) + (push (mm-quote-arg + (gnus-map-function mm-path-name-rewrite-functions file)) out)) ((string= total "%t") (push (mm-quote-arg (car type-list)) out)) (t (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) (push (substring method beg (length method)) out) - (if uses-stdin - (progn - (push "<" out) - (push (mm-quote-arg file) out))) + (when uses-stdin + (push "<" out) + (push (mm-quote-arg + (gnus-map-function mm-path-name-rewrite-functions file)) + out)) (mapconcat 'identity (nreverse out) ""))) (defun mm-remove-parts (handles) @@ -614,7 +781,7 @@ external if displayed external." (kill-buffer (get-text-property 0 'buffer handle)))) ((and (listp handle) (stringp (car handle))) - (mm-destroy-parts (cdr handle))) + (mm-destroy-parts handle)) (t (mm-destroy-part handle))))))) @@ -635,7 +802,7 @@ external if displayed external." ((consp object) (ignore-errors (delete-file (car object))) (ignore-errors (delete-directory (file-name-directory (car object)))) - (ignore-errors (kill-buffer (cdr object)))) + (ignore-errors (and (cdr object) (kill-buffer (cdr object))))) ((bufferp object) (when (buffer-live-p object) (kill-buffer object))))) @@ -652,6 +819,18 @@ external if displayed external." (when (string-match (car elem) type) (return elem)))) +(defun mm-automatic-display-p (handle) + "Say whether the user wants HANDLE to be displayed automatically." + (let ((methods mm-automatic-display) + (type (mm-handle-media-type handle)) + method result) + (while (setq method (pop methods)) + (when (and (not (mm-inline-override-p handle)) + (string-match method type)) + (setq result t + methods nil))) + result)) + (defun mm-inlinable-p (handle) "Say whether HANDLE can be displayed inline." (let ((alist mm-inline-media-tests) @@ -665,28 +844,14 @@ external if displayed external." (pop alist)) test)) -(defun mm-automatic-display-p (handle) - "Say whether the user wants HANDLE to be displayed automatically." - (let ((methods mm-automatic-display) - (type (mm-handle-media-type handle)) - method result) - (while (setq method (pop methods)) - (when (and (not (mm-inline-override-p handle)) - (string-match method type) - (mm-inlinable-p handle)) - (setq result t - methods nil))) - result)) - (defun mm-inlined-p (handle) - "Say whether the user wants HANDLE to be displayed automatically." + "Say whether the user wants HANDLE to be displayed inline." (let ((methods mm-inlined-types) (type (mm-handle-media-type handle)) method result) (while (setq method (pop methods)) (when (and (not (mm-inline-override-p handle)) - (string-match method type) - (mm-inlinable-p handle)) + (string-match method type)) (setq result t methods nil))) result)) @@ -754,23 +919,52 @@ external if displayed external." (save-excursion (if (member (mm-handle-media-supertype handle) '("text" "message")) (with-temp-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - (let ((temp (current-buffer))) - (set-buffer cur) - (insert-buffer-substring temp))) + (insert-buffer-substring (mm-handle-buffer handle)) + (prog1 + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + (let ((temp (current-buffer))) + (set-buffer cur) + (insert-buffer-substring temp)))) (mm-with-unibyte-buffer (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - (let ((temp (current-buffer))) - (set-buffer cur) - (insert-buffer-substring temp))))))) - -(defvar mm-default-directory nil) + (prog1 + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + (let ((temp (current-buffer))) + (set-buffer cur) + (insert-buffer-substring temp)))))))) + +(defun mm-file-name-delete-whitespace (file-name) + "Remove all whitespace characters from FILE-NAME." + (while (string-match "\\s-+" file-name) + (setq file-name (replace-match "" t t file-name))) + file-name) + +(defun mm-file-name-trim-whitespace (file-name) + "Remove leading and trailing whitespace characters from FILE-NAME." + (when (string-match "\\`\\s-+" file-name) + (setq file-name (substring file-name (match-end 0)))) + (when (string-match "\\s-+\\'" file-name) + (setq file-name (substring file-name 0 (match-beginning 0)))) + file-name) + +(defun mm-file-name-collapse-whitespace (file-name) + "Collapse multiple whitespace characters in FILE-NAME." + (while (string-match "\\s-\\s-+" file-name) + (setq file-name (replace-match " " t t file-name))) + file-name) + +(defun mm-file-name-replace-whitespace (file-name) + "Replace whitespace characters in FILE-NAME with underscores. +Set `mm-file-name-replace-whitespace' to any other string if you do not +like underscores." + (let ((s (or mm-file-name-replace-whitespace "_"))) + (while (string-match "\\s-" file-name) + (setq file-name (replace-match s t t file-name)))) + file-name) (defun mm-save-part (handle) "Write HANDLE to a file." @@ -779,7 +973,8 @@ external if displayed external." (mm-handle-disposition handle) 'filename)) file) (when filename - (setq filename (file-name-nondirectory filename))) + (setq filename (gnus-map-function mm-file-name-rewrite-functions + (file-name-nondirectory filename)))) (setq file (read-file-name "Save MIME part to: " (expand-file-name @@ -812,7 +1007,8 @@ external if displayed external." (read-string "Shell command on MIME part: " mm-last-shell-command))) (mm-with-unibyte-buffer (mm-insert-part handle) - (shell-command-on-region (point-min) (point-max) command nil)))) + (let ((coding-system-for-write 'binary)) + (shell-command-on-region (point-min) (point-max) command nil))))) (defun mm-interactively-view-part (handle) "Display HANDLE using METHOD." @@ -825,9 +1021,9 @@ external if displayed external." (completing-read "Viewer: " methods)))) (when (string= method "") (error "No method given")) - (if (string-match "^[^% \t]+$" method) + (if (string-match "^[^% \t]+$" method) (setq method (concat method " %s"))) - (mm-display-external (copy-sequence handle) method))) + (mm-display-external handle method))) (defun mm-preferred-alternative (handles &optional preferred) "Say which of HANDLES are preferred." @@ -865,6 +1061,35 @@ external if displayed external." "Return the handle(s) referred to by ID." (cdr (assoc id mm-content-id-alist))) +(defconst mm-image-type-regexps + '(("/\\*.*XPM.\\*/" . xpm) + ("P[1-6]" . pbm) + ("GIF8" . gif) + ("\377\330" . jpeg) + ("\211PNG\r\n" . png) + ("#define" . xbm) + ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff) + ("%!PS" . postscript)) + "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types. +When the first bytes of an image file match REGEXP, it is assumed to +be of image type IMAGE-TYPE.") + +;; Steal from image.el. image-type-from-data suffers multi-line matching bug. +(defun mm-image-type-from-buffer () + "Determine the image type from data in the current buffer. +Value is a symbol specifying the image type or nil if type cannot +be determined." + (let ((types mm-image-type-regexps) + type) + (goto-char (point-min)) + (while (and types (null type)) + (let ((regexp (car (car types))) + (image-type (cdr (car types)))) + (when (looking-at regexp) + (setq type image-type)) + (setq types (cdr types)))) + type)) + (defun mm-get-image (handle) "Return an image instance based on HANDLE." (let ((type (mm-handle-media-subtype handle)) @@ -876,6 +1101,8 @@ external if displayed external." "xpm") ((equal type "x-xbitmap") "xbm") + ((equal type "x-portable-bitmap") + "pbm") (t type))) (or (mm-handle-cache handle) (mm-with-unibyte-buffer @@ -883,31 +1110,40 @@ external if displayed external." (prog1 (setq spec (ignore-errors - ;; Avoid testing `make-glyph' since W3 may define - ;; a bogus version of it. + ;; Avoid testing `make-glyph' since W3 may define + ;; a bogus version of it. (if (fboundp 'create-image) - (create-image (buffer-string) (intern type) 'data-p) - (cond - ((equal type "xbm") - ;; xbm images require special handling, since - ;; the only way to create glyphs from these - ;; (without a ton of work) is to write them - ;; out to a file, and then create a file - ;; specifier. - (let ((file (make-temp-name - (expand-file-name "emm.xbm" - mm-tmp-directory)))) - (unwind-protect - (progn - (write-region (point-min) (point-max) file) - (make-glyph (list (cons 'x file)))) - (ignore-errors - (delete-file file))))) - (t - (make-glyph - (vector (intern type) :data (buffer-string)))))))) + (create-image (buffer-string) + (or (mm-image-type-from-buffer) + (intern type)) + 'data-p) + (mm-create-image-xemacs type)))) (mm-handle-set-cache handle spec)))))) +(defun mm-create-image-xemacs (type) + (cond + ((equal type "xbm") + ;; xbm images require special handling, since + ;; the only way to create glyphs from these + ;; (without a ton of work) is to write them + ;; out to a file, and then create a file + ;; specifier. + (let ((file (make-temp-name + (expand-file-name "emm.xbm" + mm-tmp-directory)))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file) + (make-glyph (list (cons 'x file)))) + (ignore-errors + (delete-file file))))) + (t + (make-glyph + (vector + (or (mm-image-type-from-buffer) + (intern type)) + :data (buffer-string)))))) + (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) @@ -943,7 +1179,7 @@ external if displayed external." (and (mm-valid-image-format-p format) (mm-image-fit-p handle))) -(defun mm-find-part-by-type (handles type &optional notp recursive) +(defun mm-find-part-by-type (handles type &optional notp recursive) "Search in HANDLES for part with TYPE. If NOTP, returns first non-matching part. If RECURSIVE, search recursively." @@ -961,10 +1197,11 @@ If RECURSIVE, search recursively." (setq handles (cdr handles))) handle)) -(defun mm-find-raw-part-by-type (ctl type &optional notp) +(defun mm-find-raw-part-by-type (ctl type &optional notp) (goto-char (point-min)) - (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) - (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) + (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl + 'boundary))) + (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$")) start (end (save-excursion (goto-char (point-max)) @@ -972,29 +1209,29 @@ If RECURSIVE, search recursively." (match-beginning 0) (point-max)))) result) - (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) + (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$")) (while (and (not result) (re-search-forward boundary end t)) (goto-char (match-beginning 0)) (when start (save-excursion (save-restriction - (narrow-to-region start (point)) - (when (let ((ctl (ignore-errors - (mail-header-parse-content-type + (narrow-to-region start (1- (point))) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type (mail-fetch-field "content-type"))))) (if notp (not (equal (car ctl) type)) (equal (car ctl) type))) (setq result (buffer-substring (point-min) (point-max))))))) - (forward-line 2) + (forward-line 1) (setq start (point))) (when (and (not result) start) (save-excursion (save-restriction (narrow-to-region start end) - (when (let ((ctl (ignore-errors - (mail-header-parse-content-type + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type (mail-fetch-field "content-type"))))) (if notp (not (equal (car ctl) type)) @@ -1007,16 +1244,29 @@ If RECURSIVE, search recursively." (defsubst mm-set-handle-multipart-parameter (handle parameter value) ;; HANDLE could be a CTL. (if handle - (put-text-property 0 (length (car handle)) parameter value + (put-text-property 0 (length (car handle)) parameter value (car handle)))) (defun mm-possibly-verify-or-decrypt (parts ctl) - (let ((subtype (cadr (split-string (car ctl) "/"))) + (let ((type (car ctl)) + (subtype (cadr (split-string (car ctl) "/"))) (mm-security-handle ctl) ;; (car CTL) is the type. protocol func functest) - (cond + (cond + ((or (equal type "application/x-pkcs7-mime") + (equal type "application/pkcs7-mime")) + (with-temp-buffer + (when (and (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) t) + (t (y-or-n-p + (format "Decrypt (S/MIME) part? ")))) + (mm-view-pkcs7 parts)) + (setq parts (mm-dissect-buffer t))))) ((equal subtype "signed") - (unless (and (setq protocol (mail-content-type-get ctl 'protocol)) + (unless (and (setq protocol + (mm-handle-multipart-ctl-parameter ctl 'protocol)) (not (equal protocol "multipart/mixed"))) ;; The message is broken or draft-ietf-openpgp-multsig-01. (let ((protocols mm-verify-function-alist)) @@ -1031,10 +1281,10 @@ If RECURSIVE, search recursively." (if (cond ((eq mm-verify-option 'never) nil) ((eq mm-verify-option 'always) t) - ((eq mm-verify-option 'known) - (and func - (or (not (setq functest - (nth 3 (assoc protocol + ((eq mm-verify-option 'known) + (and func + (or (not (setq functest + (nth 3 (assoc protocol mm-verify-function-alist)))) (funcall functest parts ctl)))) (t (y-or-n-p @@ -1044,15 +1294,16 @@ If RECURSIVE, search recursively." (save-excursion (if func (funcall func parts ctl) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (format "Unknown sign protocol (%s)" protocol)))))) ((equal subtype "encrypted") - (unless (setq protocol (mail-content-type-get ctl 'protocol)) + (unless (setq protocol + (mm-handle-multipart-ctl-parameter ctl 'protocol)) ;; The message is broken. (let ((parts parts)) (while parts - (if (assoc (mm-handle-media-type (car parts)) + (if (assoc (mm-handle-media-type (car parts)) mm-decrypt-function-alist) (setq protocol (mm-handle-media-type (car parts)) parts nil) @@ -1062,24 +1313,46 @@ If RECURSIVE, search recursively." ((eq mm-decrypt-option 'never) nil) ((eq mm-decrypt-option 'always) t) ((eq mm-decrypt-option 'known) - (and func - (or (not (setq functest - (nth 3 (assoc protocol + (and func + (or (not (setq functest + (nth 3 (assoc protocol mm-decrypt-function-alist)))) (funcall functest parts ctl)))) - (t (y-or-n-p + (t (y-or-n-p (format "Decrypt (%s) part? " (or (nth 2 (assoc protocol mm-decrypt-function-alist)) (format "protocol=%s" protocol)))))) (save-excursion (if func (setq parts (funcall func parts ctl)) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (format "Unknown encrypt protocol (%s)" protocol)))))) (t nil)) parts)) +(defun mm-multiple-handles (handles) + (and (listp (car handles)) + (> (length handles) 1))) + +(defun mm-merge-handles (handles1 handles2) + (append + (if (listp (car handles1)) + handles1 + (list handles1)) + (if (listp (car handles2)) + handles2 + (list handles2)))) + +(defun mm-readable-p (handle) + "Say whether the content of HANDLE is readable." + (and (< (with-current-buffer (mm-handle-buffer handle) + (buffer-size)) 10000) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (and (eq (mm-body-7-or-8) '7bit) + (not (mm-long-lines-p 76)))))) + (provide 'mm-decode) ;;; mm-decode.el ends here