* mm-decode.el (mm-dissect-singlepart): Check that the decoder exists.

[gnus] / lisp / mm-decode.el

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index e2c23d9..e6407cf 100644 (file)
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,47 +1,46 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
 
 ;;; 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-2012  Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;; This file is part of GNU Emacs.
 
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;; 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
 ;; 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
 
 ;; 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
 ;; 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 <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 ;;; Code:
 
 
 ;;; Commentary:
 
 ;;; Code:
 

-;; For Emacs < 22.2.
+;; For Emacs <22.2 and XEmacs.

 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 
 (require 'mail-parse)
 (eval-and-compile
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
 
 (require 'mail-parse)

-(require 'mailcap)

 (require 'mm-bodies)
 (require 'mm-bodies)

-(require 'gnus-util)
+(require 'mm-archive)

 (eval-when-compile (require 'cl)
                   (require 'term))
 
 (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-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")

 
 (defvar gnus-current-window-configuration)
 
 
 (defvar gnus-current-window-configuration)
 


@@ -106,38 +105,38 @@
         ,disposition ,description ,cache ,id))
 
 (defcustom mm-text-html-renderer
         ,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)
        ((executable-find "links") 'links)
        ((executable-find "lynx") 'lynx)

-       (t 'html2text))
+       ((locate-library "w3") 'w3)
+       ((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:
   "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;
 `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;
+`w3': use Emacs/W3;
+`html2text': use html2text;
+nil    : use external viewer (default web browser)."
+  :version "24.1"
+  :type '(choice (const shr)
+                 (const gnus-w3m)
+                 (const w3)
+                 (const w3m :tag "emacs-w3m")
+                (const w3m-standalone :tag "standalone w3m" )

                 (const links)
                 (const lynx)
                 (const html2text)
                 (const links)
                 (const lynx)
                 (const html2text)

-                (const nil)
+                (const nil :tag "External viewer")

                 (function))
   :group 'mime-display)
 
                 (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 <img> tags.  It has no effect on Emacs/w3.  See also the
 (defcustom mm-inline-text-html-with-images nil
   "If non-nil, Gnus will allow retrieving images in HTML contents with
 the <img> tags.  It has no effect on Emacs/w3.  See also the


@@ -197,7 +196,7 @@ before the external MIME handler is invoked."
     ("image/tiff"
      mm-inline-image
      (lambda (handle)
     ("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)
     ("image/xbm"
      mm-inline-image
      (lambda (handle)


@@ -225,22 +224,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/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/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/dns" mm-display-dns-inline identity)

+    ("text/x-org" mm-display-org-inline identity)

     ("text/html"
      mm-inline-text-html
      (lambda (handle)
     ("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)
     ("text/x-vcard"
      mm-inline-text-vcard
      (lambda (handle)


@@ -268,6 +266,20 @@ before the external MIME handler is invoked."
     ("multipart/alternative" ignore identity)
     ("multipart/mixed" ignore identity)
     ("multipart/related" ignore identity)
     ("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)
     ;; Disable audio and image
     ("audio/.*" ignore ignore)
     ("image/.*" ignore ignore)


@@ -312,7 +324,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/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)
   "A list of MIME types to be displayed automatically."
   :type '(repeat regexp)
   :group 'mime-display)


@@ -348,7 +361,7 @@ to:
  (\"text/html\" \"text/richtext\")
 
 Adding \"image/.*\" might also be useful.  Spammers use it as the
  (\"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'.
 `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'.


@@ -365,8 +378,12 @@ enables you to choose manually one of two types those mails include."
   :group 'mime-display)
 
 (defcustom mm-inline-large-images nil
   :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
   :group 'mime-display)
 
 (defcustom mm-file-name-rewrite-functions


@@ -394,7 +411,7 @@ functions), `mm-file-name-delete-whitespace',
               (repeat :inline t
                       :tag "Function"
                       function)))
               (repeat :inline t
                       :tag "Function"
                       function)))

-  :version "23.0" ;; No Gnus
+  :version "23.1" ;; No Gnus

   :group 'mime-display)
 
 
   :group 'mime-display)
 
 


@@ -548,6 +565,8 @@ Postpone undisplaying of viewers for types in
     (message "Destroying external MIME viewers")
     (mm-destroy-parts mm-postponed-undisplay-list)))
 
     (message "Destroying external MIME viewers")
     (mm-destroy-parts mm-postponed-undisplay-list)))
 

+(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."
   (save-excursion
 (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
   "Dissect the current buffer and return a list of MIME handles."
   (save-excursion


@@ -560,8 +579,16 @@ 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")
          (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")))
                id (mail-fetch-field "content-id"))
          (unless from
            (setq from (mail-fetch-field "from")))


@@ -570,7 +597,10 @@ Postpone undisplaying of viewers for types in
          ;; creates unibyte buffers. This `if', though not a perfect
          ;; solution, avoids most of them.
          (if from
          ;; 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
       (if (or (not ctl)
              (not (string-match "/" (car ctl))))
          (mm-dissect-singlepart


@@ -612,7 +642,7 @@ Postpone undisplaying of viewers for types in
             no-strict-mime
             (and cd (mail-header-parse-content-disposition cd))
             description id)
             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)))
        (when id
          (when (string-match " *<\\(.*\\)> *" id)
            (setq id (match-string 1 id)))


@@ -624,8 +654,14 @@ Postpone undisplaying of viewers for types in
            (if (equal "text/plain" (car ctl))
                (assoc 'format ctl)
              t))
            (if (equal "text/plain" (car ctl))
                (assoc 'format ctl)
              t))

-    (mm-make-handle
-     (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
+    (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
+              (executable-find (cadr decoder)))
+         (mm-dissect-archive handle)
+       handle))))

 
 (defun mm-dissect-multipart (ctl from)
   (goto-char (point-min))
 
 (defun mm-dissect-multipart (ctl from)
   (goto-char (point-min))


@@ -654,19 +690,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)))))
        (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."
 
 (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
     (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))))
 
       (insert-buffer-substring obuf beg)
       (current-buffer))))
 


@@ -680,13 +717,17 @@ Postpone undisplaying of viewers for types in
          (goto-char (point-max)))
       (mapcar 'mm-display-parts handle))))
 
          (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)
   "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")
        (mm-remove-part handle)
       (let* ((ehandle (if (equal (mm-handle-media-type handle)
                                 "message/external-body")


@@ -739,6 +780,7 @@ external if displayed external."
                 handle 'mailcap-save-binary-file)))))))))
 
 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
                 handle 'mailcap-save-binary-file)))))))))
 
 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))

+(defvar mailcap-mime-extensions)       ; mailcap-mime-info autoloads

 
 (defun mm-display-external (handle method)
   "Display HANDLE using METHOD."
 
 (defun mm-display-external (handle method)
   "Display HANDLE using METHOD."


@@ -751,6 +793,7 @@ external if displayed external."
                  (set-buffer (generate-new-buffer " *mm*"))
                  (setq method nil))
              (mm-insert-part handle)
                  (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)))
              (let ((win (get-buffer-window cur t)))
                (when win
                  (select-window win)))


@@ -774,6 +817,7 @@ external if displayed external."
                  (mm-handle-set-undisplayer handle mm)))))
        ;; The function is a string to be executed.
        (mm-insert-part handle)
                  (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
        (let* ((dir (mm-make-temp-file
                     (expand-file-name "emm." mm-tmp-directory) 'dir))
               (filename (or


@@ -788,7 +832,7 @@ external if displayed external."
               (copiousoutput (assoc "copiousoutput" mime-info))
               file buffer)
          ;; We create a private sub-directory where we store our files.
               (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
          (if filename
              (setq file (expand-file-name
                          (gnus-map-function mm-file-name-rewrite-functions


@@ -808,6 +852,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))
                                            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
          (message "Viewing with %s" method)
          (cond
           (needsterm


@@ -901,7 +949,7 @@ external if displayed external."
                          ;; In particular, the timer object (which is
                          ;; a vector in Emacs but is a list in XEmacs)
                          ;; requires that it is lexically scoped.
                          ;; 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)))
+                         (timer (run-at-time 30.0 nil 'ignore)))

                       (if (featurep 'xemacs)
                           (lambda (process state)
                             (when (eq 'exit (process-status process))
                       (if (featurep 'xemacs)
                           (lambda (process state)
                             (when (eq 'exit (process-status process))


@@ -1120,21 +1168,21 @@ in HANDLE."
 
 (defmacro mm-with-part (handle &rest forms)
   "Run FORMS in the temp buffer containing the contents of 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))
 
 (put 'mm-with-part 'lisp-indent-function 1)
 (put 'mm-with-part 'edebug-form-spec '(body))
 


@@ -1227,10 +1275,17 @@ PROMPT overrides the default one used to ask user for a file name."
       (setq filename (gnus-map-function mm-file-name-rewrite-functions
                                        (file-name-nondirectory filename))))
     (setq file
       (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 ""))))
+          (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))))
+    (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? "
     (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? "


@@ -1239,11 +1294,11 @@ PROMPT overrides the default one used to ask user for a file name."
           (mm-save-part-to-file handle file)
           file))))
 
           (mm-save-part-to-file handle file)
           file))))
 

-(defun mm-add-meta-html-tag (handle &optional charset)
+(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
   "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.  Return t if meta tag is added
-or replaced."
+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)
   (when (equal (mm-handle-media-type handle) "text/html")
     (when (or charset
              (setq charset (mail-content-type-get (mm-handle-type handle)


@@ -1254,8 +1309,9 @@ or replaced."
        (goto-char (point-min))
        (if (re-search-forward "\
 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
        (goto-char (point-min))
        (if (re-search-forward "\
 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\

-text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+?\\)\\)?[\"'][^>]*>" nil t)
-           (if (and (match-beginning 2)
+text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
+           (if (and (not force-charset)
+                    (match-beginning 2)

                     (string-match "\\`html\\'" (match-string 1)))
                ;; Don't modify existing meta tag.
                nil
                     (string-match "\\`html\\'" (match-string 1)))
                ;; Don't modify existing meta tag.
                nil


@@ -1281,22 +1337,26 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+?\\)\\)?[\"'][^>]*>" nil t)
          (mm-write-region (point-min) (point-max) file nil nil nil 'binary t)
        (set-default-file-modes current-file-modes)))))
 
          (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)))))
 
     (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
 (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))
                  (mailcap-mime-info type 'all)))
         (method (let ((minibuffer-local-completion-map
                        mm-viewer-completion-map))


@@ -1331,13 +1391,19 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+?\\)\\)?[\"'][^>]*>" nil t)
 
 (defun mm-preferred-alternative-precedence (handles)
   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
 
 (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."
 
 (defun mm-get-content-id (id)
   "Return the handle(s) referred to by ID."


@@ -1427,13 +1493,15 @@ be determined."
            (intern type))
        :data (buffer-string)))))))
 
            (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 (featurep 'xemacs)
            ;; XEmacs' glyphs can actually tell us about their width, so
 (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 (featurep 'xemacs)
            ;; XEmacs' glyphs can actually tell us about their width, so

-           ;; lets be nice and smart about them.
+           ;; 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))))
            (or mm-inline-large-images
                (and (<= (glyph-width image) (window-pixel-width))
                     (<= (glyph-height image) (window-pixel-height))))


@@ -1450,7 +1518,7 @@ be determined."
    ;; Handle XEmacs
    ((fboundp 'valid-image-instantiator-format-p)
     (valid-image-instantiator-format-p format))
    ;; 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)))
    ((fboundp 'image-type-available-p)
     (and (display-graphic-p)
         (image-type-available-p format)))


@@ -1531,7 +1599,7 @@ If RECURSIVE, search recursively."
 
 (autoload 'mm-view-pkcs7 "mm-view")
 
 
 (autoload 'mm-view-pkcs7 "mm-view")
 

-(defun mm-possibly-verify-or-decrypt (parts ctl)
+(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.
   (let ((type (car ctl))
        (subtype (cadr (split-string (car ctl) "/")))
        (mm-security-handle ctl) ;; (car CTL) is the type.


@@ -1546,7 +1614,7 @@ If RECURSIVE, search recursively."
                    ((eq mm-decrypt-option 'known) t)
                    (t (y-or-n-p
                        (format "Decrypt (S/MIME) part? "))))
                    ((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
          (setq parts (mm-dissect-buffer t)))))
      ((equal subtype "signed")
       (unless (and (setq protocol


@@ -1645,7 +1713,72 @@ If RECURSIVE, search recursively."
         (and (eq (mm-body-7-or-8) '7bit)
              (not (mm-long-lines-p 76))))))
 
         (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-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))
+                             (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))))
+        (libxml-parse-html-region (point-min) (point-max))))
+      (mm-handle-set-undisplayer
+       handle
+       `(lambda ()
+         (let ((inhibit-read-only t))
+           (delete-region ,(point-min-marker)
+                          ,(point-max-marker))))))))
+
+(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)
 
 (provide 'mm-decode)
 

-;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b

 ;;; mm-decode.el ends here
 ;;; mm-decode.el ends here