X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=ec60b54155d630bc5bcd3c00b204ca37d3e795c4;hb=23544667b54a01c4dbe52137060eb3817394c6f6;hp=2949b1c6d863230e35538261d1d4fe90df22c942;hpb=d25777c19f06e9eb4c0f26a8348b18ad221fd7ea;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 2949b1c6d..ec60b5415 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,5 +1,7 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -17,8 +19,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -31,16 +33,17 @@ (require 'term)) (eval-and-compile - (autoload 'executable-find "executable") (autoload 'mm-inline-partial "mm-partial") (autoload 'mm-inline-external-body "mm-extern") (autoload 'mm-insert-inline "mm-view")) +(defvar gnus-current-window-configuration) + (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") + :link '(custom-manual "(emacs-mime)Display Customization") :version "21.1" :group 'mail :group 'news @@ -48,7 +51,7 @@ (defgroup mime-security () "MIME security in mail and news articles." - :link '(custom-manual "(emacs-mime)Customization") + :link '(custom-manual "(emacs-mime)Display Customization") :group 'mail :group 'news :group 'multimedia) @@ -98,24 +101,31 @@ (defcustom mm-text-html-renderer (cond ((locate-library "w3") 'w3) - ((locate-library "w3m") 'w3m) + ((executable-find "w3m") (if (locate-library "w3m") + 'w3m + 'w3m-standalone)) ((executable-find "links") 'links) - ((executable-find "lynx") 'lynx)) + ((executable-find "lynx") 'lynx) + (t 'html2text)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`w3' : using Emacs/W3; -`w3m' : using emacs-w3m; -`links': using links; -`lynx' : using lynx; -`nil' : using external viewer." - :type '(choice (symbol w3) - (symbol w3m) - (symbol links) - (symbol lynx) - (symbol nil) +`w3' : use Emacs/W3; +`w3m' : use emacs-w3m; +`w3m-standalone': use w3m; +`links': use links; +`lynx' : use lynx; +`html2text' : use html2text; +nil : use external viewer." + :version "22.1" + :type '(choice (const w3) + (const w3m) + (const w3m-standalone) + (const links) + (const lynx) + (const html2text) + (const nil) (function)) - :version "21.3" :group 'mime-display) (defvar mm-inline-text-html-renderer nil @@ -123,22 +133,50 @@ The defined renderer types are: It is suggested to customize `mm-text-html-renderer' instead.") (defcustom mm-inline-text-html-with-images nil - "If non-nil, Gnus will allow retrieving images in the HTML contents -with tags. It has no effect on Emacs/w3. For emacs-w3m, the -value of the option `w3m-display-inline-images' will be bound with -this value. In addition, the variable `w3m-safe-url-regexp' will be -bound with the value nil if it is non-nil to make emacs-w3m show all -images, however this behavior may be changed in the future." + "If non-nil, Gnus will allow retrieving images in HTML contents with +the tags. It has no effect on Emacs/w3. See also the +documentation for the `mm-w3m-safe-url-regexp' variable." + :version "22.1" :type 'boolean :group 'mime-display) +(defcustom mm-w3m-safe-url-regexp "\\`cid:" + "Regexp matching URLs which are considered to be safe. +Some HTML mails might contain a nasty trick used by spammers, using +the tag which is far more evil than the [Click Here!] button. +It is most likely intended to check whether the ominous spam mail has +reached your eyes or not, in which case the spammer knows for sure +that your email address is valid. It is done by embedding an +identifier string into a URL that you might automatically retrieve +when displaying the image. The default value is \"\\\\`cid:\" which only +matches parts embedded to the Multipart/Related type MIME contents and +Gnus will never connect to the spammer's site arbitrarily. You may +set this variable to nil if you consider all urls to be safe." + :version "22.1" + :type '(choice (regexp :tag "Regexp") + (const :tag "All URLs are safe" nil)) + :group 'mime-display) + (defcustom mm-inline-text-html-with-w3m-keymap t "If non-nil, use emacs-w3m command keys in the article buffer." + :version "22.1" :type 'boolean :group 'mime-display) +(defcustom mm-enable-external t + "Indicate whether external MIME handlers should be used. + +If t, all defined external MIME handlers are used. If nil, files are saved by +`mailcap-save-binary-file'. If it is the symbol `ask', you are prompted +before the external MIME handler is invoked." + :version "22.1" + :type '(choice (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "Ask" ask)) + :group 'mime-display) + (defcustom mm-inline-media-tests - '(("image/jpeg" + '(("image/p?jpeg" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'jpeg handle))) @@ -166,7 +204,7 @@ images, however this behavior may be changed in the future." mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) - ("image/x-pixmap" + ("image/x-xpixmap" mm-inline-image (lambda (handle) (mm-valid-and-fit-image-p 'xpm handle))) @@ -183,9 +221,15 @@ images, however this behavior may be changed in the future." ("text/richtext" mm-inline-text identity) ("text/x-patch" mm-display-patch-inline (lambda (handle) - (locate-library "diff-mode"))) + ;; If the diff-mode.el package is installed, the function is + ;; autoloaded. Checking (locate-library "diff-mode") would be trying + ;; to cater to broken installations. OTOH checking the function + ;; makes it possible to install another package which provides an + ;; alternative implementation of diff-mode. --Stef + (fboundp 'diff-mode))) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("text/dns" mm-display-dns-inline identity) ("text/html" mm-inline-text-html (lambda (handle) @@ -224,7 +268,7 @@ images, however this behavior may be changed in the future." ;; 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") + :type '(repeat (list (regexp :tag "MIME type") (function :tag "Display function") (function :tag "Display test"))) :group 'mime-display) @@ -232,6 +276,7 @@ images, however this behavior may be changed in the future." (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" "message/partial" "message/external-body" "application/emacs-lisp" + "application/x-emacs-lisp" "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime") @@ -246,14 +291,16 @@ type inline." "application/pdf" "application/x-dvi") "List of media types for which the external viewer will not be killed when selecting a different article." + :version "22.1" :type '(repeat string) :group 'mime-display) (defcustom mm-automatic-display - '("text/plain" "text/enriched" "text/richtext" "text/html" + '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" - "message/rfc822" "text/x-patch" "application/pgp-signature" - "application/emacs-lisp" "application/x-pkcs7-signature" + "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature" + "application/emacs-lisp" "application/x-emacs-lisp" + "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime") "A list of MIME types to be displayed automatically." @@ -293,9 +340,11 @@ to: :group 'mime-display) (defcustom mm-tmp-directory - (cond ((fboundp 'temp-directory) (temp-directory)) - ((boundp 'temporary-file-directory) temporary-file-directory) - ("/tmp/")) + (if (fboundp 'temp-directory) + (temp-directory) + (if (boundp 'temporary-file-directory) + temporary-file-directory + "/tmp/")) "Where mm will store its temporary files." :type 'directory :group 'mime-display) @@ -305,11 +354,14 @@ to: :type 'boolean :group 'mime-display) -(defvar mm-file-name-rewrite-functions nil +(defvar mm-file-name-rewrite-functions + '(mm-file-name-delete-control mm-file-name-delete-gotchas) "*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-control' +`mm-file-name-delete-gotchas' `mm-file-name-delete-whitespace', `mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace', @@ -318,10 +370,10 @@ Ready-made functions include `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. + "*List of functions for rewriting the full file names of MIME parts. +This is used when viewing parts externally, and is meant for +transforming the absolute 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.") @@ -334,14 +386,20 @@ If not set, `default-directory' will be used." :type '(choice directory (const :tag "Default" nil)) :group 'mime-display) +(defcustom mm-attachment-file-modes 384 + "Set the mode bits of saved attachments to this integer." + :version "22.1" + :type 'integer + :group 'mime-display) + (defcustom mm-external-terminal-program "xterm" "The program to start an external terminal." + :version "22.1" :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) @@ -368,7 +426,8 @@ If not set, `default-directory' will be used." (defcustom mm-verify-option 'never "Option of verifying signed parts. `never', not verify; `always', always verify; -`known', only verify known protocols. Otherwise, ask user." +`known', only verify known protocols. Otherwise, ask user." + :version "22.1" :type '(choice (item always) (item never) (item :tag "only known protocols" known) @@ -386,7 +445,8 @@ If not set, `default-directory' will be used." (defcustom mm-decrypt-option nil "Option of decrypting encrypted parts. `never', not decrypt; `always', always decrypt; -`known', only decrypt known protocols. Otherwise, ask user." +`known', only decrypt known protocols. Otherwise, ask user." + :version "22.1" :type '(choice (item always) (item never) (item :tag "only known protocols" known) @@ -396,21 +456,19 @@ If not set, `default-directory' will be used." (defvar mm-viewer-completion-map (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) (set-keymap-parent map minibuffer-local-completion-map) + ;; Should we bind other key to minibuffer-complete-word? + (define-key map " " 'self-insert-command) 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) - (defvar mm-viewer-completion-map (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) (set-keymap-parent map minibuffer-local-completion-map) + ;; Should we bind other key to minibuffer-complete-word? + (define-key map " " 'self-insert-command) 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. (defun mm-alist-to-plist (alist) @@ -442,8 +500,9 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (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." + "Set the undisplayer for HANDLE to FUNCTION. +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) @@ -456,10 +515,10 @@ for types in mm-keep-viewer-alive-types." (message "Destroying external MIME viewers") (mm-destroy-parts mm-postponed-undisplay-list))) -(defun mm-dissect-buffer (&optional no-strict-mime loose-mime) +(defun mm-dissect-buffer (&optional no-strict-mime loose-mime from) "Dissect the current buffer and return a list of MIME handles." (save-excursion - (let (ct ctl type subtype cte cd description id result from) + (let (ct ctl type subtype cte cd description id result) (save-restriction (mail-narrow-to-head) (when (or no-strict-mime @@ -470,23 +529,20 @@ for types in mm-keep-viewer-alive-types." cte (mail-fetch-field "content-transfer-encoding") cd (mail-fetch-field "content-disposition") description (mail-fetch-field "content-description") - from (mail-fetch-field "from") id (mail-fetch-field "content-id")) + (unless from + (setq from (mail-fetch-field "from"))) ;; 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) (not (string-match "/" (car ctl)))) (mm-dissect-singlepart (list mm-dissect-default-type) - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (ignore-errors (mail-header-parse-content-disposition cd))) description) @@ -499,29 +555,27 @@ for types in mm-keep-viewer-alive-types." ((equal type "multipart") (let ((mm-dissect-default-type (if (equal subtype "digest") "message/rfc822" - "text/plain"))) + "text/plain")) + (start (cdr (assq 'start (cdr 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 + ;; the mm-handle API so we simply store the multipart buffer ;; name as a text property of the "multipart/whatever" string. (add-text-properties 0 (length (car ctl)) - (list 'buffer (mm-copy-to-buffer)) - (car ctl)) - (add-text-properties 0 (length (car ctl)) - (list 'from from) + (list 'buffer (mm-copy-to-buffer) + 'from from + 'start start) (car ctl)) - (cons (car ctl) (mm-dissect-multipart ctl)))) + (cons (car ctl) (mm-dissect-multipart ctl from)))) (t (mm-possibly-verify-or-decrypt (mm-dissect-singlepart ctl - (and cte (intern (downcase (mail-header-remove-whitespace - (mail-header-remove-comments - cte))))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (ignore-errors (mail-header-parse-content-disposition cd))) @@ -538,18 +592,10 @@ for types in mm-keep-viewer-alive-types." (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (let ((res (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) - (push (car res) mm-dissection-list) - res))) - -(defun mm-remove-all-parts () - "Remove all MIME handles." - (interactive) - (mapcar 'mm-remove-part mm-dissection-list) - (setq mm-dissection-list nil)) - -(defun mm-dissect-multipart (ctl) + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id))) + +(defun mm-dissect-multipart (ctl from) (goto-char (point-min)) (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) @@ -566,7 +612,7 @@ for types in mm-keep-viewer-alive-types." (save-excursion (save-restriction (narrow-to-region start (point)) - (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) + (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts))))) (end-of-line 2) (or (looking-at boundary) (forward-line 1)) @@ -575,7 +621,7 @@ for types in mm-keep-viewer-alive-types." (save-excursion (save-restriction (narrow-to-region start end) - (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) + (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts))))) (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) (defun mm-copy-to-buffer () @@ -586,7 +632,10 @@ for types in mm-keep-viewer-alive-types." (goto-char (point-min)) (search-forward-regexp "^\n" nil t) (setq beg (point)) - (set-buffer (generate-new-buffer " *mm*")) + (set-buffer + ;; Preserve the data's unibyteness (for url-insert-file-contents). + (let ((default-enable-multibyte-characters (mm-multibyte-p))) + (generate-new-buffer " *mm*"))) (insert-buffer-substring obuf beg) (current-buffer)))) @@ -609,7 +658,13 @@ external if displayed external." (if (mm-handle-displayed-p handle) (mm-remove-part handle) (let* ((type (mm-handle-media-type handle)) - (method (mailcap-mime-info type))) + (method (mailcap-mime-info type)) + (filename (or (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (mm-handle-type handle) 'name) + "")) + (external mm-enable-external)) (if (and (mm-inlinable-p handle) (mm-inlined-p handle)) (progn @@ -624,8 +679,27 @@ external if displayed external." (forward-line 1) (mm-insert-inline handle (mm-get-part handle)) 'inline) - (mm-display-external - handle (or method 'mailcap-save-binary-file))))))))) + (if (and method ;; If nil, we always use "save". + (stringp method) ;; 'mailcap-save-binary-file + (or (eq mm-enable-external t) + (and (eq mm-enable-external 'ask) + (y-or-n-p + (concat + "Display part (" type + ") using external program" + ;; Can non-string method ever happen? + (if (stringp method) + (concat + " \"" (format method filename) "\"") + "") + "? "))))) + (setq external t) + (setq external nil)) + (if external + (mm-display-external + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -646,7 +720,8 @@ external if displayed external." (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) (goto-char (point-min)) - (message "Viewing with %s" method) + (when method + (message "Viewing with %s" method)) (let ((mm (current-buffer)) (non-viewer (assq 'non-viewer (mailcap-mime-info @@ -660,13 +735,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 (or + (let* ((dir (mm-make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir)) + (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) - (mail-content-type-get - (mm-handle-type handle) 'name))) + (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) @@ -674,47 +749,45 @@ external if displayed external." (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) ;; We create a private sub-directory where we store our files. - (make-directory dir) (set-file-modes dir 448) (if filename - (setq file (expand-file-name (file-name-nondirectory filename) - dir)) - (setq file (make-temp-name (expand-file-name "mm." dir)))) + (setq file (expand-file-name + (gnus-map-function mm-file-name-rewrite-functions + (file-name-nondirectory filename)) + dir)) + (setq file (mm-make-temp-file (expand-file-name "mm." dir)))) (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 - (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))))) - (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)) + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (if window-system + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch command) + (require 'term) + (require 'gnus-win) + (set-buffer + (setq buffer + (make-term "display" + shell-file-name + nil + shell-command-switch command))) + (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..." command)) 'external) (copiousoutput (with-current-buffer outbuf @@ -731,8 +804,7 @@ external if displayed external." (mm-mailcap-command method file (mm-handle-type handle))) (if (buffer-live-p buffer) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (buffer-string)))) (progn (ignore-errors (delete-file file)) @@ -741,17 +813,38 @@ external if displayed external." (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)) + (let ((command (mm-mailcap-command + method file (mm-handle-type handle)))) + (unwind-protect + (progn + (start-process "*display*" + (setq buffer + (generate-new-buffer " *mm*")) + shell-file-name + shell-command-switch command) + (set-process-sentinel + (get-buffer-process buffer) + `(lambda (process state) + (when (eq 'exit (process-status process)) + ;; Don't use `ignore-errors'. + (condition-case nil + (delete-file ,file) + (error)) + (condition-case nil + (delete-directory ,(file-name-directory file)) + (error)) + (condition-case nil + (kill-buffer ,buffer) + (error)) + (condition-case nil + ,(macroexpand (list 'mm-handle-set-undisplayer + (list 'quote handle) + nil)) + (error)) + (message "Displaying %s...done" ,command))))) + (mm-handle-set-external-undisplayer + handle (cons file buffer))) + (message "Displaying %s..." command)) 'external))))))) (defun mm-mailcap-command (method file type-list) @@ -759,7 +852,8 @@ external if displayed external." (beg 0) (uses-stdin t) out sub total) - (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg) + (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%" + method beg) (push (substring method beg (match-beginning 0)) out) (setq beg (match-end 0) total (match-string 0 method) @@ -767,18 +861,21 @@ external if displayed external." (cond ((string= total "%%") (push "%" out)) - ((string= total "%s") + ((or (string= total "%s") + ;; We do our own quoting. + (string= total "'%s'") + (string= total "\"%s\"")) (setq uses-stdin nil) - (push (mm-quote-arg + (push (shell-quote-argument (gnus-map-function mm-path-name-rewrite-functions file)) out)) ((string= total "%t") - (push (mm-quote-arg (car type-list)) out)) + (push (shell-quote-argument (car type-list)) out)) (t - (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out)))) + (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out)))) (push (substring method beg (length method)) out) (when uses-stdin (push "<" out) - (push (mm-quote-arg + (push (shell-quote-argument (gnus-map-function mm-path-name-rewrite-functions file)) out)) (mapconcat 'identity (nreverse out) ""))) @@ -832,9 +929,18 @@ external if displayed external." (funcall object)) ;; Externally displayed part. ((consp object) + (condition-case () + (while (get-buffer-process (cdr object)) + (interrupt-process (get-buffer-process (cdr object))) + (message "Waiting for external displayer to die...") + (sit-for 1)) + (quit) + (error)) + (ignore-errors (and (cdr object) (kill-buffer (cdr object)))) + (message "Waiting for external displayer to die...done") (ignore-errors (delete-file (car object))) - (ignore-errors (delete-directory (file-name-directory (car object)))) - (ignore-errors (and (cdr object) (kill-buffer (cdr object))))) + (ignore-errors (delete-directory (file-name-directory + (car object))))) ((bufferp object) (when (buffer-live-p object) (kill-buffer object))))) @@ -938,7 +1044,7 @@ external if displayed external." "Return the contents of HANDLE as a string." (mm-with-unibyte-buffer (insert (with-current-buffer (mm-handle-buffer handle) - (mm-with-unibyte-current-buffer-mule4 + (mm-with-unibyte-current-buffer (buffer-string)))) (mm-decode-content-transfer-encoding (mm-handle-encoding handle) @@ -947,27 +1053,16 @@ external if displayed external." (defun mm-insert-part (handle) "Insert the contents of HANDLE in the current buffer." - (let ((cur (current-buffer))) - (save-excursion - (if (member (mm-handle-media-supertype handle) '("text" "message")) - (with-temp-buffer - (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)) - (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)))))))) + (save-excursion + (insert + (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset) + 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + ((mm-multibyte-p) + (mm-string-as-multibyte (mm-get-part handle))) + (t + (mm-get-part handle)))))) (defun mm-file-name-delete-whitespace (file-name) "Remove all whitespace characters from FILE-NAME." @@ -991,15 +1086,25 @@ external if displayed external." (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." +Set the option `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." +(defun mm-file-name-delete-control (filename) + "Delete control characters from FILENAME." + (gnus-replace-in-string filename "[\x00-\x1f\x7f]" "")) + +(defun mm-file-name-delete-gotchas (filename) + "Delete shell gotchas from FILENAME." + (setq filename (gnus-replace-in-string filename "[<>|]" "")) + (gnus-replace-in-string filename "^[.-]+" "")) + +(defun mm-save-part (handle &optional prompt) + "Write HANDLE to a file. +PROMPT overrides the default one used to ask user for a file name." (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) (filename (mail-content-type-get (mm-handle-disposition handle) 'filename)) @@ -1008,10 +1113,10 @@ like underscores." (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 - (or filename name "") - (or mm-default-directory default-directory)))) + (mm-with-multibyte + (read-file-name (or prompt "Save MIME part to: ") + (or mm-default-directory default-directory) + nil nil (or filename name "")))) (setq mm-default-directory (file-name-directory file)) (and (or (not (file-exists-p file)) (yes-or-no-p (format "File %s already exists; overwrite? " @@ -1024,13 +1129,17 @@ like underscores." (mm-with-unibyte-buffer (mm-insert-part handle) (let ((coding-system-for-write 'binary) + (current-file-modes (default-file-modes)) ;; Don't re-compress .gz & al. Arguably we should make ;; `file-name-handler-alist' nil, but that would chop ;; ange-ftp, which is reasonable to use here. (inhibit-file-name-operation 'write-region) (inhibit-file-name-handlers (cons 'jka-compr-handler inhibit-file-name-handlers))) - (write-region (point-min) (point-max) file)))) + (set-default-file-modes mm-attachment-file-modes) + (unwind-protect + (write-region (point-min) (point-max) file) + (set-default-file-modes current-file-modes))))) (defun mm-pipe-part (handle) "Pipe HANDLE to a process." @@ -1145,7 +1254,7 @@ be determined." ;; Avoid testing `make-glyph' since W3 may define ;; a bogus version of it. (if (fboundp 'create-image) - (create-image (buffer-string) + (create-image (buffer-string) (or (mm-image-type-from-buffer) (intern type)) 'data-p) @@ -1160,7 +1269,7 @@ be determined." ;; (without a ton of work) is to write them ;; out to a file, and then create a file ;; specifier. - (let ((file (make-temp-name + (let ((file (mm-make-temp-file (expand-file-name "emm.xbm" mm-tmp-directory)))) (unwind-protect @@ -1171,11 +1280,11 @@ be determined." (delete-file file))))) (t (make-glyph - (vector + (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))) @@ -1255,7 +1364,7 @@ If RECURSIVE, search recursively." (if notp (not (equal (car ctl) type)) (equal (car ctl) type))) - (setq result (buffer-substring (point-min) (point-max))))))) + (setq result (buffer-string)))))) (forward-line 1) (setq start (point))) (when (and (not result) start) @@ -1268,16 +1377,16 @@ If RECURSIVE, search recursively." (if notp (not (equal (car ctl) type)) (equal (car ctl) type))) - (setq result (buffer-substring (point-min) (point-max))))))) + (setq result (buffer-string)))))) result)) (defvar mm-security-handle nil) (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 - (car handle)))) + (when handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) (defun mm-possibly-verify-or-decrypt (parts ctl) (let ((type (car ctl)) @@ -1310,25 +1419,26 @@ If RECURSIVE, search recursively." protocols nil) (setq protocols (cdr protocols)))))) (setq func (nth 1 (assoc protocol mm-verify-function-alist))) - (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 - mm-verify-function-alist)))) - (funcall functest parts ctl)))) - (t (y-or-n-p + (when (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 + mm-verify-function-alist)))) + (funcall functest parts ctl)))) + (t + (y-or-n-p (format "Verify signed (%s) part? " (or (nth 2 (assoc protocol mm-verify-function-alist)) (format "protocol=%s" protocol)))))) - (save-excursion - (if func - (funcall func parts ctl) - (mm-set-handle-multipart-parameter - mm-security-handle 'gnus-details - (format "Unknown sign protocol (%s)" protocol)))))) + (save-excursion + (if func + (funcall func parts ctl) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown sign protocol (%s)" protocol)))))) ((equal subtype "encrypted") (unless (setq protocol (mm-handle-multipart-ctl-parameter ctl 'protocol)) @@ -1341,29 +1451,36 @@ If RECURSIVE, search recursively." parts nil) (setq parts (cdr parts)))))) (setq func (nth 1 (assoc protocol mm-decrypt-function-alist))) - (if (cond - ((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 - mm-decrypt-function-alist)))) - (funcall functest parts ctl)))) - (t (y-or-n-p + (when (cond + ((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 + mm-decrypt-function-alist)))) + (funcall functest parts ctl)))) + (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 - (format "Unknown encrypt protocol (%s)" protocol)))))) + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (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 handles) + (> (length handles) 1) + (or (listp (car handles)) + (stringp (car handles))))) + +(defun mm-complicated-handles (handles) (and (listp (car handles)) (> (length handles) 1))) @@ -1387,4 +1504,5 @@ If RECURSIVE, search recursively." (provide 'mm-decode) +;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b ;;; mm-decode.el ends here