X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=3b3695b4ca3e9e4cceb69f3f39408746a01e835d;hp=09814da65612ceea2f045c44e8132050513ab284;hb=6c7ec91b0fc3cba68595a10981820e24d031e82a;hpb=9b139a13c0650a18872ebd64849560a97554afa8 diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 09814da65..311ea7cff 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,46 +1,49 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: (require 'mail-parse) -(require 'mailcap) (require 'mm-bodies) -(eval-when-compile (require 'cl) - (require 'term)) +(eval-when-compile (require 'cl)) -(eval-and-compile - (autoload 'mm-inline-partial "mm-partial") - (autoload 'mm-inline-external-body "mm-extern") - (autoload 'mm-extern-cache-contents "mm-extern") - (autoload 'mm-insert-inline "mm-view")) +(autoload 'gnus-map-function "gnus-util") +(autoload 'gnus-replace-in-string "gnus-util") +(autoload 'gnus-read-shell-command "gnus-util") + +(autoload 'mm-inline-partial "mm-partial") +(autoload 'mm-inline-external-body "mm-extern") +(autoload 'mm-extern-cache-contents "mm-extern") +(autoload 'mm-insert-inline "mm-view") + +(autoload 'mm-archive-decoders "mm-archive") +(autoload 'mm-archive-dissect-and-inline "mm-archive") +(autoload 'mm-dissect-archive "mm-archive") (defvar gnus-current-window-configuration) (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list) +(add-hook 'gnus-exit-gnus-hook 'mm-temp-files-delete) (defgroup mime-display () "Display of MIME in mail and news articles." @@ -57,6 +60,18 @@ :group 'news :group 'multimedia) +(defface mm-command-output + '((((class color) + (background dark)) + (:foreground "ForestGreen")) + (((class color) + (background light)) + (:foreground "red3")) + (t + (:italic t))) + "Face used for displaying output from commands." + :group 'mime-display) + ;;; Convenience macros. (defmacro mm-handle-buffer (handle) @@ -101,42 +116,39 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((locate-library "w3") 'w3) - ((executable-find "w3m") (if (locate-library "w3m") - 'w3m - 'w3m-standalone)) + (cond ((fboundp 'libxml-parse-html-region) 'shr) + ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) - (t 'html2text)) + ((locate-library "html2text") 'html2text) + (t nil)) "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`w3' : use Emacs/W3; -`w3m' : use emacs-w3m; -`w3m-standalone': use w3m; +`shr': use the built-in Gnus HTML renderer; +`gnus-w3m': use Gnus renderer based on w3m; +`w3m': use emacs-w3m; +`w3m-standalone': use plain 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) +`lynx': use lynx; +`html2text': use html2text; +nil : use external viewer (default web browser)." + :version "24.1" + :type '(choice (const shr) + (const gnus-w3m) + (const w3m :tag "emacs-w3m") + (const w3m-standalone :tag "standalone w3m" ) (const links) (const lynx) (const html2text) - (const nil) + (const nil :tag "External viewer") (function)) :group 'mime-display) -(defvar mm-inline-text-html-renderer nil - "Function used for rendering inline HTML contents. -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 HTML contents with -the tags. It has no effect on Emacs/w3. See also the -documentation for the `mm-w3m-safe-url-regexp' variable." + "If non-nil, Gnus will allow retrieving images in HTML that has tags. +See also the documentation for the `mm-w3m-safe-url-regexp' +variable." :version "22.1" :type 'boolean :group 'mime-display) @@ -192,7 +204,7 @@ before the external MIME handler is invoked." ("image/tiff" mm-inline-image (lambda (handle) - (mm-valid-and-fit-image-p 'tiff handle)) ) + (mm-valid-and-fit-image-p 'tiff handle))) ("image/xbm" mm-inline-image (lambda (handle) @@ -220,22 +232,21 @@ before the external MIME handler is invoked." ("text/plain" mm-inline-text identity) ("text/enriched" mm-inline-text identity) ("text/richtext" mm-inline-text identity) - ("text/x-patch" mm-display-patch-inline - (lambda (handle) - ;; 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))) + ("text/x-patch" mm-display-patch-inline identity) + ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40). + ("text/x-diff" mm-display-patch-inline identity) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("application/x-shellscript" mm-display-shell-script-inline identity) + ("application/x-sh" mm-display-shell-script-inline identity) + ("text/x-sh" mm-display-shell-script-inline identity) + ("application/javascript" mm-display-javascript-inline identity) ("text/dns" mm-display-dns-inline identity) + ("text/x-org" mm-display-org-inline identity) ("text/html" mm-inline-text-html (lambda (handle) - (or mm-inline-text-html-renderer - mm-text-html-renderer))) + mm-text-html-renderer)) ("text/x-vcard" mm-inline-text-vcard (lambda (handle) @@ -246,6 +257,8 @@ before the external MIME handler is invoked." ("message/partial" mm-inline-partial identity) ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) + ("application/x-.?tar\\(-.*\\)?" mm-archive-dissect-and-inline identity) + ("application/zip" mm-archive-dissect-and-inline identity) ("audio/wav" mm-inline-audio (lambda (handle) (and (or (featurep 'nas-sound) (featurep 'native-sound)) @@ -263,6 +276,21 @@ before the external MIME handler is invoked." ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) ("multipart/related" ignore identity) + ("image/.*" + mm-inline-image + (lambda (handle) + (and (mm-valid-image-format-p 'imagemagick) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (let ((image + (ignore-errors + (if (fboundp 'create-image) + (create-image (buffer-string) 'imagemagick 'data-p) + (mm-create-image-xemacs + (mm-handle-media-subtype handle)))))) + (when image + (setcar (cdr handle) (list "image/imagemagick")) + (mm-image-fit-p handle))))))) ;; Disable audio and image ("audio/.*" ignore ignore) ("image/.*" ignore ignore) @@ -281,6 +309,9 @@ before the external MIME handler is invoked." "application/pgp-signature" "application/x-pkcs7-signature" "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" + "application/x-gtar-compressed" + "application/x-tar" + "application/zip" ;; Mutt still uses this even though it has already been withdrawn. "application/pgp") "List of media types that are to be displayed inline. @@ -307,7 +338,8 @@ when selecting a different article." "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" ;; Mutt still uses this even though it has already been withdrawn. - "application/pgp\\'") + "application/pgp\\'" + "text/x-org") "A list of MIME types to be displayed automatically." :type '(repeat regexp) :group 'mime-display) @@ -343,7 +375,7 @@ to: (\"text/html\" \"text/richtext\") Adding \"image/.*\" might also be useful. Spammers use it as the -prefered part of multipart/alternative messages. See also +preferred part of multipart/alternative messages. See also `gnus-buttonized-mime-types', to which adding \"multipart/alternative\" enables you to choose manually one of two types those mails include." :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'. @@ -360,8 +392,12 @@ enables you to choose manually one of two types those mails include." :group 'mime-display) (defcustom mm-inline-large-images nil - "If non-nil, then all images fit in the buffer." - :type 'boolean + "If t, then all images fit in the buffer. +If 'resize, try to resize the images so they fit." + :type '(radio + (const :tag "Inline large images as they are." t) + (const :tag "Resize large images." resize) + (const :tag "Do not inline large images." nil)) :group 'mime-display) (defcustom mm-file-name-rewrite-functions @@ -389,7 +425,7 @@ functions), `mm-file-name-delete-whitespace', (repeat :inline t :tag "Function" function))) - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :group 'mime-display) @@ -427,6 +463,12 @@ If not set, `default-directory' will be used." (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) (defvar mm-postponed-undisplay-list nil) +(defvar mm-inhibit-auto-detect-attachment nil) +(defvar mm-temp-files-to-be-deleted nil + "List of temporary files scheduled to be deleted.") +(defvar mm-temp-files-cache-file (concat ".mm-temp-files-" (user-login-name)) + "Name of a file that caches a list of temporary files to be deleted. +The file will be saved in the directory `mm-tmp-directory'.") ;; According to RFC2046, in particular, in a digest, the default ;; Content-Type value for a body part is changed from "text/plain" to @@ -489,14 +531,6 @@ result of the verification." map) "Keymap for input viewer with completion.") -(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.") - ;;; The functions. (defun mm-alist-to-plist (alist) @@ -543,8 +577,52 @@ Postpone undisplaying of viewers for types in (message "Destroying external MIME viewers") (mm-destroy-parts mm-postponed-undisplay-list))) +(defun mm-temp-files-delete () + "Delete temporary files and those parent directories. +Note that the deletion may fail if a program is catching hold of a file +under Windows or Cygwin. In that case, it schedules the deletion of +files left at the next time." + (let* ((coding-system-for-read mm-universal-coding-system) + (coding-system-for-write mm-universal-coding-system) + (cache-file (expand-file-name mm-temp-files-cache-file + mm-tmp-directory)) + (cache (when (file-exists-p cache-file) + (mm-with-multibyte-buffer + (insert-file-contents cache-file) + (split-string (buffer-string) "\n" t)))) + fails) + (dolist (temp (append cache mm-temp-files-to-be-deleted)) + (when (and (file-exists-p temp) + (if (file-directory-p temp) + ;; A parent directory left at the previous time. + (progn + (ignore-errors (delete-directory temp)) + (file-exists-p temp)) + ;; Delete a temporary file and its parent directory. + (ignore-errors (delete-file temp)) + (or (file-exists-p temp) + (progn + (setq temp (file-name-directory temp)) + (ignore-errors (delete-directory temp)) + (file-exists-p temp))))) + (push temp fails))) + (if fails + ;; Schedule the deletion of the files left at the next time. + (progn + (write-region (concat (mapconcat 'identity (nreverse fails) "\n") + "\n") + nil cache-file nil 'silent) + (set-file-modes cache-file #o600)) + (when (file-exists-p cache-file) + (ignore-errors (delete-file cache-file)))) + (setq mm-temp-files-to-be-deleted nil))) + +(autoload 'message-fetch-field "message") + (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from) - "Dissect the current buffer and return a list of MIME handles." + "Dissect the current buffer and return a list of MIME handles. +If NO-STRICT-MIME, don't require the message to have a +MIME-Version header before proceeding." (save-excursion (let (ct ctl type subtype cte cd description id result) (save-restriction @@ -555,22 +633,33 @@ Postpone undisplaying of viewers for types in (setq ct (mail-fetch-field "content-type") ctl (and ct (mail-header-parse-content-type ct)) cte (mail-fetch-field "content-transfer-encoding") - cd (mail-fetch-field "content-disposition") - description (mail-fetch-field "content-description") + cd (or (mail-fetch-field "content-disposition") + (when (and ctl + (eq 'mm-inline-text + (cadr (mm-assoc-string-match + mm-inline-media-tests + (car ctl))))) + "inline")) + ;; Newlines in description should be stripped so as + ;; not to break the MIME tag into two or more lines. + description (message-fetch-field "content-description") 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 + ;; a 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)))))) + (setq from (cadr (mail-extract-address-components from)))) + (if description + (setq description (mail-decode-encoded-word-string + description))))) (if (or (not ctl) (not (string-match "/" (car ctl)))) - (mm-dissect-singlepart + (mm-dissect-singlepart (list mm-dissect-default-type) - (and cte (intern (downcase (mail-header-strip cte)))) + (and cte (intern (downcase (mail-header-strip cte)))) no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description) @@ -607,7 +696,7 @@ Postpone undisplaying of viewers for types in no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description id) - ctl)))) + ctl from)))) (when id (when (string-match " *<\\(.*\\)> *" id) (setq id (match-string 1 id))) @@ -619,8 +708,26 @@ Postpone undisplaying of viewers for types in (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) + ;; Guess what the type of application/octet-stream parts should + ;; really be. + (let ((filename (cdr (assq 'filename (cdr cdl))))) + (when (and (not mm-inhibit-auto-detect-attachment) + (equal (car ctl) "application/octet-stream") + filename + (string-match "\\.\\([^.]+\\)$" filename)) + (let ((new-type (mailcap-extension-to-mime (match-string 1 filename)))) + (when new-type + (setcar ctl new-type))))) + (let ((handle + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id)) + (decoder (assoc (car ctl) (mm-archive-decoders)))) + (if (and decoder + ;; Do automatic decoding + (cadr decoder) + (executable-find (caddr decoder))) + (mm-dissect-archive handle) + handle)))) (defun mm-dissect-multipart (ctl from) (goto-char (point-min)) @@ -631,7 +738,9 @@ Postpone undisplaying of viewers for types in (goto-char (point-max)) (if (re-search-backward close-delimiter nil t) (match-beginning 0) - (point-max))))) + (point-max)))) + (mm-inhibit-auto-detect-attachment + (equal (car ctl) "multipart/encrypted"))) (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) (while (and (< (point) end) (re-search-forward boundary end t)) (goto-char (match-beginning 0)) @@ -649,19 +758,20 @@ Postpone undisplaying of viewers for types in (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts))))) - (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl from))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." - (let ((obuf (current-buffer)) - beg) - (goto-char (point-min)) - (search-forward-regexp "^\n" nil t) - (setq beg (point)) + (let ((obuf (current-buffer)) + (mb (mm-multibyte-p)) + beg) + (goto-char (point-min)) + (search-forward-regexp "^\n" nil t) + (setq beg (point)) (with-current-buffer - ;; Preserve the data's unibyteness (for url-insert-file-contents). - (let ((default-enable-multibyte-characters (mm-multibyte-p))) - (generate-new-buffer " *mm*")) + (generate-new-buffer " *mm*") + ;; Preserve the data's unibyteness (for url-insert-file-contents). + (mm-set-buffer-multibyte mb) (insert-buffer-substring obuf beg) (current-buffer)))) @@ -675,13 +785,17 @@ Postpone undisplaying of viewers for types in (goto-char (point-max))) (mapcar 'mm-display-parts handle)))) -(defun mm-display-part (handle &optional no-default) +(autoload 'mailcap-parse-mailcaps "mailcap") +(autoload 'mailcap-mime-info "mailcap") + +(defun mm-display-part (handle &optional no-default force) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; external if displayed external." (save-excursion (mailcap-parse-mailcaps) - (if (mm-handle-displayed-p handle) + (if (and (not force) + (mm-handle-displayed-p handle)) (mm-remove-part handle) (let* ((ehandle (if (equal (mm-handle-media-type handle) "message/external-body") @@ -697,41 +811,51 @@ external if displayed external." (mail-content-type-get (mm-handle-type handle) 'name) "")) - (external mm-enable-external)) - (if (and (mm-inlinable-p ehandle) - (mm-inlined-p ehandle)) - (progn - (forward-line 1) - (mm-display-inline handle) - 'inline) - (when (or method - (not no-default)) - (if (and (not method) - (equal "text" (car (split-string type "/")))) - (progn - (forward-line 1) - (mm-insert-inline handle (mm-get-part handle)) - 'inline) - (setq external - (and method ;; If nil, we always use "save". - (stringp method) ;; 'mailcap-save-binary-file + (external mm-enable-external) + (decoder (assoc (car (mm-handle-type handle)) + (mm-archive-decoders)))) + (cond + ((and decoder + (executable-find (caddr decoder))) + (mm-archive-dissect-and-inline handle) + 'inline) + ((and (mm-inlinable-p ehandle) + (mm-inlined-p ehandle)) + (mm-display-inline handle) + 'inline) + ((or method + (not no-default)) + (if (and (not method) + (equal "text" (car (split-string type "/")))) + (progn + (forward-line 1) + (mm-insert-inline handle (mm-get-part handle)) + 'inline) + (setq external + (and method ;; If nil, we always use "save". (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) "\"") - "") - "? ")))))) - (if external - (mm-display-external - handle (or method 'mailcap-save-binary-file)) + "using external program \"" + (format method filename) "\"") + (format + "by calling `%s' on the contents)" method)) + "? ")))))) + (if external (mm-display-external - handle 'mailcap-save-binary-file))))))))) + handle (or method 'mailcap-save-binary-file)) + (mm-display-external + handle 'mailcap-save-binary-file))))))))) + +(declare-function gnus-configure-windows "gnus-win" (setting &optional force)) +(defvar mailcap-mime-extensions) ; mailcap-mime-info autoloads +(declare-function term-mode "term" ()) +(declare-function term-char-mode "term" ()) (defun mm-display-external (handle method) "Display HANDLE using METHOD." @@ -744,6 +868,7 @@ external if displayed external." (set-buffer (generate-new-buffer " *mm*")) (setq method nil)) (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let ((win (get-buffer-window cur t))) (when win (select-window win))) @@ -760,13 +885,22 @@ external if displayed external." (mm-handle-media-type handle) t)))) (unwind-protect (if method - (funcall method) + (progn + (when (and (boundp 'gnus-summary-buffer) + (bufferp gnus-summary-buffer) + (buffer-name gnus-summary-buffer)) + ;; So that we pop back to the right place, sort of. + (switch-to-buffer gnus-summary-buffer) + (switch-to-buffer mm)) + (delete-other-windows) + (funcall method)) (mm-save-part handle)) (when (and (not non-viewer) method) (mm-handle-set-undisplayer handle mm))))) ;; The function is a string to be executed. (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let* ((dir (mm-make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) (filename (or @@ -781,7 +915,7 @@ external if displayed external." (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) ;; We create a private sub-directory where we store our files. - (set-file-modes dir 448) + (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -801,6 +935,10 @@ external if displayed external." nil suffix)))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) + ;; The file is deleted after the viewer exists. If the users edits + ;; the file, changes will be lost. Set file to read-only to make it + ;; clear. + (set-file-modes file #o400) (message "Viewing with %s" method) (cond (needsterm @@ -808,10 +946,20 @@ external if displayed external." 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) + (set-process-sentinel + (start-process "*display*" nil + mm-external-terminal-program + "-e" shell-file-name + shell-command-switch command) + `(lambda (process state) + (if (eq 'exit (process-status process)) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file ,file)) + (ignore-errors (delete-directory + ,(file-name-directory + file)))))))) (require 'term) (require 'gnus-win) (set-buffer @@ -825,11 +973,15 @@ external if displayed external." (set-process-sentinel (get-buffer-process buffer) `(lambda (process state) - (if (eq 'exit (process-status process)) - (gnus-configure-windows - ',gnus-current-window-configuration)))) + (when (eq 'exit (process-status process)) + (ignore-errors (delete-file ,file)) + (ignore-errors + (delete-directory ,(file-name-directory file))) + (gnus-configure-windows + ',gnus-current-window-configuration)))) (gnus-configure-windows 'display-term)) - (mm-handle-set-external-undisplayer handle (cons file buffer))) + (mm-handle-set-external-undisplayer handle (cons file buffer)) + (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external) (copiousoutput @@ -862,7 +1014,7 @@ external if displayed external." (let ((command (mm-mailcap-command method file (mm-handle-type handle)))) (unwind-protect - (progn + (let ((process-connection-type nil)) (start-process "*display*" (setq buffer (generate-new-buffer " *mm*")) @@ -870,48 +1022,37 @@ external if displayed external." shell-command-switch command) (set-process-sentinel (get-buffer-process buffer) - (lexical-let ;; Don't use `let'. - ;; Function used to remove temp file and directory. - ((fn `(lambda nil - ;; Don't use `ignore-errors'. - (condition-case nil - (delete-file ,file) - (error)) - (condition-case nil - (delete-directory - ,(file-name-directory file)) - (error)))) - ;; Form uses to kill the process buffer and - ;; remove the undisplayer. - (fm `(progn - (kill-buffer ,buffer) - ,(macroexpand - (list 'mm-handle-set-undisplayer - (list 'quote handle) - nil)))) - ;; Message to be issued when the process exits. - (done (format "Displaying %s...done" command)) - ;; In particular, the timer object (which is - ;; a vector in Emacs but is a list in XEmacs) - ;; requires that it is lexically scoped. - (timer (run-at-time 2.0 nil 'ignore))) - (if (boundp 'itimer-list) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer itimer-list) - (set-itimer-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))) - (lambda (process state) - (when (eq 'exit (process-status process)) - (if (memq timer timer-list) - (timer-set-function timer fn) - (funcall fn)) - (ignore-errors (eval fm)) - (message "%s" done))))))) + (lexical-let ((outbuf outbuf) + (file file) + (buffer buffer) + (command command) + (handle handle)) + (lambda (process state) + (when (eq (process-status process) 'exit) + (run-at-time + 60.0 nil + (lambda () + (ignore-errors (delete-file file)) + (ignore-errors (delete-directory + (file-name-directory file))))) + (when (buffer-live-p outbuf) + (with-current-buffer outbuf + (let ((buffer-read-only nil) + (point (point))) + (forward-line 2) + (let ((start (point))) + (mm-insert-inline + handle (with-current-buffer buffer + (buffer-string))) + (put-text-property start (point) + 'face 'mm-command-output)) + (goto-char point)))) + (when (buffer-live-p buffer) + (kill-buffer buffer))) + (message "Displaying %s...done" command))))) (mm-handle-set-external-undisplayer - handle (cons file buffer))) + handle (cons file buffer)) + (add-to-list 'mm-temp-files-to-be-deleted file t)) (message "Displaying %s..." command)) 'external))))))) @@ -990,7 +1131,8 @@ external if displayed external." (cond ;; Internally displayed part. ((mm-annotationp object) - (delete-annotation object)) + (if (featurep 'xemacs) + (delete-annotation object))) ((or (functionp object) (and (listp object) (eq (car object) 'lambda))) @@ -1112,21 +1254,21 @@ in HANDLE." (defmacro mm-with-part (handle &rest forms) "Run FORMS in the temp buffer containing the contents of HANDLE." - `(let* ((handle ,handle) - ;; The multibyteness of the temp buffer should be turned on - ;; if inserting a multibyte string. Contrarily, the buffer's - ;; multibyteness should be off if inserting a unibyte string, - ;; especially if a string contains 8bit data. - (default-enable-multibyte-characters - (with-current-buffer (mm-handle-buffer handle) - (mm-multibyte-p)))) - (with-temp-buffer - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-disable-multibyte) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - ,@forms))) + ;; The handle-buffer's content is a sequence of bytes, not a sequence of + ;; chars, so the buffer should be unibyte. It may happen that the + ;; handle-buffer is multibyte for some reason, in which case now is a good + ;; time to adjust it, since we know at this point that it should + ;; be unibyte. + `(let* ((handle ,handle)) + (when (and (mm-handle-buffer handle) + (buffer-name (mm-handle-buffer handle))) + (with-temp-buffer + (mm-disable-multibyte) + (insert-buffer-substring (mm-handle-buffer handle)) + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + ,@forms)))) (put 'mm-with-part 'lisp-indent-function 1) (put 'mm-with-part 'edebug-form-spec '(body)) @@ -1218,11 +1360,30 @@ PROMPT overrides the default one used to ask user for a file name." (when filename (setq filename (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)))) - (setq file - (mm-with-multibyte - (read-file-name (or prompt "Save MIME part to: ") - (or mm-default-directory default-directory) - nil nil (or filename "")))) + (while + (progn + (setq file + (read-file-name + (or prompt + (format "Save MIME part to (default %s): " + (or filename ""))) + (or mm-default-directory default-directory) + (expand-file-name (or filename "") + (or mm-default-directory default-directory)))) + (cond ((or (not file) (equal file "")) + (message "Please enter a file name") + t) + ((and (file-directory-p file) + (not filename)) + (message "Please enter a non-directory file name") + t) + (t nil))) + (sit-for 2) + (discard-input)) + (if (file-directory-p file) + (setq file (expand-file-name filename file)) + (setq file (expand-file-name + file (or mm-default-directory default-directory)))) (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? " @@ -1231,9 +1392,40 @@ PROMPT overrides the default one used to ask user for a file name." (mm-save-part-to-file handle file) file)))) +(defun mm-add-meta-html-tag (handle &optional charset force-charset) + "Add meta html tag to specify CHARSET of HANDLE in the current buffer. +CHARSET defaults to the one HANDLE specifies. Existing meta tag that +specifies charset will not be modified unless FORCE-CHARSET is non-nil. +Return t if meta tag is added or replaced." + (when (equal (mm-handle-media-type handle) "text/html") + (when (or charset + (setq charset (mail-content-type-get (mm-handle-type handle) + 'charset))) + (setq charset (format "\ +" charset)) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (re-search-forward "\ +]+\\)\\)?[^>]*>" nil t) + (if (and (not force-charset) + (match-beginning 2) + (string-match "\\`html\\'" (match-string 1))) + ;; Don't modify existing meta tag. + nil + ;; Replace it with the one specifying charset. + (replace-match charset) + t) + (if (re-search-forward "\\s-*" nil t) + (insert charset "\n") + (re-search-forward "]+\\|\\s-*\\)>\\s-*" nil t) + (insert "\n" charset "\n\n")) + t))))) + (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let ((current-file-modes (default-file-modes))) (set-default-file-modes mm-attachment-file-modes) (unwind-protect @@ -1243,21 +1435,26 @@ PROMPT overrides the default one used to ask user for a file name." (mm-write-region (point-min) (point-max) file nil nil nil 'binary t) (set-default-file-modes current-file-modes))))) -(defun mm-pipe-part (handle) - "Pipe HANDLE to a process." - (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command - (read-string "Shell command on MIME part: " mm-last-shell-command))) +(defun mm-pipe-part (handle &optional cmd) + "Pipe HANDLE to a process. +Use CMD as the process." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (command (or cmd + (gnus-read-shell-command + "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer (mm-insert-part handle) + (mm-add-meta-html-tag handle) (let ((coding-system-for-write 'binary)) (shell-command-on-region (point-min) (point-max) command nil))))) +(autoload 'gnus-completing-read "gnus-util") + (defun mm-interactively-view-part (handle) "Display HANDLE using METHOD." (let* ((type (mm-handle-media-type handle)) (methods - (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) + (mapcar (lambda (i) (cdr (assoc 'viewer i))) (mailcap-mime-info type 'all))) (method (let ((minibuffer-local-completion-map mm-viewer-completion-map)) @@ -1292,13 +1489,19 @@ PROMPT overrides the default one used to ask user for a file name." (defun mm-preferred-alternative-precedence (handles) "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." - (let ((seq (nreverse (mapcar #'mm-handle-media-type - handles)))) - (dolist (disc (reverse mm-discouraged-alternatives)) - (dolist (elem (copy-sequence seq)) - (when (string-match disc elem) - (setq seq (nconc (delete elem seq) (list elem)))))) - seq)) + (setq handles (reverse handles)) + (dolist (disc (reverse mm-discouraged-alternatives)) + (dolist (handle (copy-sequence handles)) + (when (string-match disc (mm-handle-media-type handle)) + (setq handles (nconc (delete handle handles) (list handle)))))) + ;; Remove empty parts. + (dolist (handle (copy-sequence handles)) + (when (and (bufferp (mm-handle-buffer handle)) + (not (with-current-buffer (mm-handle-buffer handle) + (goto-char (point-min)) + (re-search-forward "[^ \t\n]" nil t)))) + (setq handles (nconc (delete handle handles) (list handle))))) + (mapcar #'mm-handle-media-type handles)) (defun mm-get-content-id (id) "Return the handle(s) referred to by ID." @@ -1364,36 +1567,39 @@ be determined." (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 (mm-make-temp-file - (expand-file-name "emm" mm-tmp-directory) - nil ".xbm"))) - (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)))))) + (when (featurep 'xemacs) + (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 (mm-make-temp-file + (expand-file-name "emm" mm-tmp-directory) + nil ".xbm"))) + (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))))))) + +(declare-function image-size "image.c" (spec &optional pixels frame)) (defun mm-image-fit-p (handle) "Say whether the image in HANDLE will fit the current window." (let ((image (mm-get-image handle))) (or (not image) - (if (fboundp 'glyph-width) - ;; XEmacs' glyphs can actually tell us about their width, so - ;; lets be nice and smart about them. + (if (featurep 'xemacs) + ;; XEmacs's glyphs can actually tell us about their width, so + ;; let's be nice and smart about them. (or mm-inline-large-images (and (<= (glyph-width image) (window-pixel-width)) (<= (glyph-height image) (window-pixel-height)))) @@ -1410,7 +1616,7 @@ be determined." ;; Handle XEmacs ((fboundp 'valid-image-instantiator-format-p) (valid-image-instantiator-format-p format)) - ;; Handle Emacs 21 + ;; Handle Emacs ((fboundp 'image-type-available-p) (and (display-graphic-p) (image-type-available-p format))) @@ -1489,7 +1695,9 @@ If RECURSIVE, search recursively." (put-text-property 0 (length (car handle)) parameter value (car handle)))) -(defun mm-possibly-verify-or-decrypt (parts ctl) +(autoload 'mm-view-pkcs7 "mm-view") + +(defun mm-possibly-verify-or-decrypt (parts ctl &optional from) (let ((type (car ctl)) (subtype (cadr (split-string (car ctl) "/"))) (mm-security-handle ctl) ;; (car CTL) is the type. @@ -1504,7 +1712,7 @@ If RECURSIVE, search recursively." ((eq mm-decrypt-option 'known) t) (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) - (mm-view-pkcs7 parts)) + (mm-view-pkcs7 parts from)) (setq parts (mm-dissect-buffer t))))) ((equal subtype "signed") (unless (and (setq protocol @@ -1536,7 +1744,7 @@ If RECURSIVE, search recursively." (format "protocol=%s" protocol)))))) (save-excursion (if func - (funcall func parts ctl) + (setq parts (funcall func parts ctl)) (mm-set-handle-multipart-parameter mm-security-handle 'gnus-details (format "Unknown sign protocol (%s)" protocol)))))) @@ -1603,7 +1811,104 @@ If RECURSIVE, search recursively." (and (eq (mm-body-7-or-8) '7bit) (not (mm-long-lines-p 76)))))) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) +(declare-function shr-insert-document "shr" (dom)) +(defvar shr-blocked-images) +(defvar gnus-inhibit-images) +(autoload 'gnus-blocked-images "gnus-art") + +(defun mm-shr (handle) + ;; Require since we bind its variables. + (require 'shr) + (let ((article-buffer (current-buffer)) + (shr-width fill-column) + (shr-content-function (lambda (id) + (let ((handle (mm-get-content-id id))) + (when handle + (mm-with-part handle + (buffer-string)))))) + shr-inhibit-images shr-blocked-images charset char) + (if (and (boundp 'gnus-summary-buffer) + (bufferp gnus-summary-buffer) + (buffer-name gnus-summary-buffer)) + (with-current-buffer gnus-summary-buffer + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) + (unless handle + (setq handle (mm-dissect-buffer t))) + (setq charset (mail-content-type-get (mm-handle-type handle) 'charset)) + (save-restriction + (narrow-to-region (point) (point)) + (shr-insert-document + (mm-with-part handle + (insert (prog1 + (if (and charset + (setq charset + (mm-charset-to-coding-system charset + nil t)) + (not (eq charset 'ascii))) + (mm-decode-coding-string (buffer-string) charset) + (mm-string-as-multibyte (buffer-string))) + (erase-buffer) + (mm-enable-multibyte))) + (goto-char (point-min)) + (setq case-fold-search t) + (while (re-search-forward + "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) + (when (setq char + (cdr (assq (if (match-beginning 1) + (string-to-number (match-string 1) 16) + (string-to-number (match-string 2))) + mm-extra-numeric-entities))) + (replace-match (char-to-string char)))) + ;; Remove "soft hyphens". + (goto-char (point-min)) + (while (search-forward "­" nil t) + (replace-match "" t t)) + (libxml-parse-html-region (point-min) (point-max)))) + (unless (bobp) + (insert "\n")) + (mm-convert-shr-links) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t)) + (delete-region ,(copy-marker (point-min) t) + ,(point-max-marker)))))))) + +(defvar shr-map) + +(autoload 'widget-convert-button "wid-edit") + +(defun mm-convert-shr-links () + (let ((start (point-min)) + end) + (while (and start + (< start (point-max))) + (when (setq start (text-property-not-all start (point-max) 'shr-url nil)) + (setq end (next-single-property-change start 'shr-url nil (point-max))) + (widget-convert-button + 'url-link start end + :help-echo (get-text-property start 'help-echo) + :keymap shr-map + (get-text-property start 'shr-url)) + (put-text-property start end 'local-map nil) + (setq start end))))) + +(defun mm-handle-filename (handle) + "Return filename of HANDLE if any." + (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename))) + (provide 'mm-decode) -;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b +;; Local Variables: +;; coding: utf-8 +;; End: + ;;; mm-decode.el ends here