X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=21819051a8f1d05b6bed05e2cfccd0d6519ff834;hb=b2398720282867dd778a1fe6ee4d63fd3674e757;hp=8d98903c6cba889c5bab053ccbb8ddf37f341e44;hpb=58c37f854255b656f04e79913c9fd0bbbef61f8c;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 8d98903c6..21819051a 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -22,14 +22,6 @@ ;;; Commentary: -;; Jaap-Henk Hoepman (jhh@xs4all.nl): -;; -;; Added support for delayed destroy of external MIME viewers. All external -;; viewers for mime types in mm-keep-viewer-alive-types will remain active -;; after switching articles or groups, and will only be removed when exiting -;; gnus. -;; - ;;; Code: (require 'mail-parse) @@ -103,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 @@ -151,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) @@ -177,8 +184,8 @@ ("application/pgp-signature" ignore identity) ("application/x-pkcs7-signature" ignore identity) ("application/pkcs7-signature" ignore identity) - ("application/x-pkcs7-mime" mm-view-pkcs7 identity) - ("application/pkcs7-mime" mm-view-pkcs7 identity) + ("application/x-pkcs7-mime" ignore identity) + ("application/pkcs7-mime" ignore identity) ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) ("multipart/related" ignore identity) @@ -226,7 +233,9 @@ when selecting a different article." (defcustom mm-attachment-override-types '("text/x-vcard" "application/pkcs7-mime" - "application/x-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) @@ -279,13 +288,21 @@ Ready-made functions include `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 'directory + :type '(choice directory (const :tag "Default" nil)) :group 'mime-display) (defcustom mm-external-terminal-program "xterm" @@ -406,8 +423,9 @@ for types in mm-keep-viewer-alive-types." (mm-handle-set-undisplayer handle function))) (defun mm-destroy-postponed-undisplay-list () - (message "Destroying external MIME viewers") - (mm-destroy-parts mm-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." @@ -456,10 +474,10 @@ for types in mm-keep-viewer-alive-types." (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 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. + ;; 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)) (list 'buffer (mm-copy-to-buffer)) (car ctl)) @@ -468,14 +486,17 @@ for types in mm-keep-viewer-alive-types." (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))) @@ -607,16 +628,20 @@ 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) (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) - ;; We create a private sub-directory where we store our files. + ;; We create a private sub-directory where we store our files. (make-directory dir) (set-file-modes dir 448) (if filename @@ -626,74 +651,76 @@ 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 - (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)) - '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-external-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)) @@ -710,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) @@ -891,20 +920,22 @@ external if displayed external." (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))) + (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))))))) + (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." @@ -1086,30 +1117,33 @@ be determined." (or (mm-image-type-from-buffer) (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 - (or (mm-image-type-from-buffer) - (intern type)) - :data (buffer-string)))))))) + (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))) @@ -1214,10 +1248,22 @@ If RECURSIVE, search recursively." (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 + ((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 (mm-handle-multipart-ctl-parameter ctl 'protocol))