Add 2011 to FSF/AIST copyright years.

[gnus] / lisp / mm-decode.el

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index f9d8311..5a3972e 100644 (file)
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,7 +1,7 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
 
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
 ;;; mm-decode.el --- Functions for decoding MIME things
 
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,

-;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;     MORIOKA Tomohiko <morioka@jaist.ac.jp>


@@ -24,22 +24,23 @@
 
 ;;; Code:
 
 
 ;;; 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)

 (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)
 


@@ -104,10 +105,8 @@
         ,disposition ,description ,cache ,id))
 
 (defcustom mm-text-html-renderer
         ,disposition ,description ,cache ,id))
 
 (defcustom mm-text-html-renderer

-  (cond ((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)
        ((locate-library "w3") 'w3)
        ((executable-find "links") 'links)
        ((executable-find "lynx") 'lynx)
        ((locate-library "w3") 'w3)


@@ -116,6 +115,8 @@
   "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:

+`shr': use Gnus simple HTML renderer;
+`gnus-w3m' : use Gnus renderer based on w3m;

 `w3m'  : use emacs-w3m;
 `w3m-standalone': use w3m;
 `links': use links;
 `w3m'  : use emacs-w3m;
 `w3m-standalone': use w3m;
 `links': use links;


@@ -123,9 +124,11 @@ The defined renderer types are:
 `w3'   : use Emacs/W3;
 `html2text' : use html2text;
 nil    : use external viewer (default web browser)."
 `w3'   : use Emacs/W3;
 `html2text' : use html2text;
 nil    : use external viewer (default web browser)."

-  :version "23.0" ;; No Gnus
-  :type '(choice (const w3)
-                (const w3m :tag "emacs-w3m")
+  :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 w3m-standalone :tag "standalone w3m" )
                 (const links)
                 (const lynx)


@@ -134,10 +137,6 @@ nil    : use external viewer (default web browser)."
                 (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


@@ -242,8 +241,7 @@ before the external MIME handler is invoked."
     ("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)


@@ -368,8 +366,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


@@ -551,6 +553,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


@@ -564,7 +568,9 @@ Postpone undisplaying of viewers for types in
                ctl (and ct (mail-header-parse-content-type ct))
                cte (mail-fetch-field "content-transfer-encoding")
                cd (mail-fetch-field "content-disposition")
                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")
+               ;; 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")))


@@ -618,7 +624,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)))


@@ -660,7 +666,7 @@ 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."


@@ -687,13 +693,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")


@@ -746,6 +756,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."


@@ -1139,13 +1150,15 @@ in HANDLE."
   ;; time to adjust it, since we know at this point that it should
   ;; be unibyte.
   `(let* ((handle ,handle))
   ;; time to adjust it, since we know at this point that it should
   ;; be unibyte.
   `(let* ((handle ,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)))
+     (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))
 


@@ -1238,9 +1251,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

-          (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? "


@@ -1249,11 +1270,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)


@@ -1264,8 +1285,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


@@ -1291,26 +1313,30 @@ 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))