*** empty log message ***

[gnus] / lisp / mm-decode.el

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index bfb7b6f..ec60b54 100644 (file)
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,6 +1,7 @@
 ;;; 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
-;;        Free Software Foundation, Inc.
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;;   2005 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>


@@ -18,8 +19,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the

-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -36,6 +37,8 @@
   (autoload 'mm-inline-external-body "mm-extern")
   (autoload 'mm-insert-inline "mm-view"))
 
   (autoload 'mm-inline-external-body "mm-extern")
   (autoload 'mm-insert-inline "mm-view"))
 

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

 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
 
 (defgroup mime-display ()
 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
 
 (defgroup mime-display ()


@@ -114,6 +117,7 @@ The defined renderer types are:
 `lynx' : use lynx;
 `html2text' : use html2text;
 nil    : use external viewer."
 `lynx' : use lynx;
 `html2text' : use html2text;
 nil    : use external viewer."

+  :version "22.1"

   :type '(choice (const w3)
                 (const w3m)
                 (const w3m-standalone)
   :type '(choice (const w3)
                 (const w3m)
                 (const w3m-standalone)


@@ -122,7 +126,6 @@ nil    : use external viewer."
                 (const html2text)
                 (const nil)
                 (function))
                 (const html2text)
                 (const nil)
                 (function))

-  :version "21.3"

   :group 'mime-display)
 
 (defvar mm-inline-text-html-renderer nil
   :group 'mime-display)
 
 (defvar mm-inline-text-html-renderer nil


@@ -133,6 +136,7 @@ It is suggested to customize `mm-text-html-renderer' instead.")
   "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
 documentation for the `mm-w3m-safe-url-regexp' variable."
   "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
 documentation for the `mm-w3m-safe-url-regexp' variable."

+  :version "22.1"

   :type 'boolean
   :group 'mime-display)
 
   :type 'boolean
   :group 'mime-display)
 


@@ -148,12 +152,14 @@ when displaying the image.  The default value is \"\\\\`cid:\" which only
 matches parts embedded to the Multipart/Related type MIME contents and
 Gnus will never connect to the spammer's site arbitrarily.  You may
 set this variable to nil if you consider all urls to be safe."
 matches parts embedded to the Multipart/Related type MIME contents and
 Gnus will never connect to the spammer's site arbitrarily.  You may
 set this variable to nil if you consider all urls to be safe."

+  :version "22.1"

   :type '(choice (regexp :tag "Regexp")
                 (const :tag "All URLs are safe" nil))
   :group 'mime-display)
 
 (defcustom mm-inline-text-html-with-w3m-keymap t
   "If non-nil, use emacs-w3m command keys in the article buffer."
   :type '(choice (regexp :tag "Regexp")
                 (const :tag "All URLs are safe" nil))
   :group 'mime-display)
 
 (defcustom mm-inline-text-html-with-w3m-keymap t
   "If non-nil, use emacs-w3m command keys in the article buffer."

+  :version "22.1"

   :type 'boolean
   :group 'mime-display)
 
   :type 'boolean
   :group 'mime-display)
 


@@ -163,7 +169,7 @@ set this variable to nil if you consider all urls to be safe."
 If t, all defined external MIME handlers are used.  If nil, files are saved by
 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 before the external MIME handler is invoked."
 If t, all defined external MIME handlers are used.  If nil, files are saved by
 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 before the external MIME handler is invoked."

-  :version "21.4"
+  :version "22.1"

   :type '(choice (const :tag "Always" t)
                 (const :tag "Never" nil)
                 (const :tag "Ask" ask))
   :type '(choice (const :tag "Always" t)
                 (const :tag "Never" nil)
                 (const :tag "Ask" ask))


@@ -215,9 +221,15 @@ before the external MIME handler is invoked."
     ("text/richtext" mm-inline-text identity)
     ("text/x-patch" mm-display-patch-inline
      (lambda (handle)
     ("text/richtext" mm-inline-text identity)
     ("text/x-patch" mm-display-patch-inline
      (lambda (handle)

-       (locate-library "diff-mode")))
+       ;; If the diff-mode.el package is installed, the function is
+       ;; autoloaded.  Checking (locate-library "diff-mode") would be trying
+       ;; to cater to broken installations.  OTOH checking the function
+       ;; makes it possible to install another package which provides an
+       ;; alternative implementation of diff-mode.  --Stef
+       (fboundp 'diff-mode)))

     ("application/emacs-lisp" mm-display-elisp-inline identity)
     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
     ("application/emacs-lisp" mm-display-elisp-inline identity)
     ("application/x-emacs-lisp" mm-display-elisp-inline identity)

+    ("text/dns" mm-display-dns-inline identity)

     ("text/html"
      mm-inline-text-html
      (lambda (handle)
     ("text/html"
      mm-inline-text-html
      (lambda (handle)


@@ -279,13 +291,14 @@ type inline."
     "application/pdf" "application/x-dvi")
   "List of media types for which the external viewer will not be killed
 when selecting a different article."
     "application/pdf" "application/x-dvi")
   "List of media types for which the external viewer will not be killed
 when selecting a different article."

+  :version "22.1"

   :type '(repeat string)
   :group 'mime-display)
 
 (defcustom mm-automatic-display
   :type '(repeat string)
   :group 'mime-display)
 
 (defcustom mm-automatic-display

-  '("text/plain" "text/enriched" "text/richtext" "text/html"
+  '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"

     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"

-    "message/rfc822" "text/x-patch" "application/pgp-signature"
+    "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"

     "application/emacs-lisp" "application/x-emacs-lisp"
     "application/x-pkcs7-signature"
     "application/pkcs7-signature" "application/x-pkcs7-mime"
     "application/emacs-lisp" "application/x-emacs-lisp"
     "application/x-pkcs7-signature"
     "application/pkcs7-signature" "application/x-pkcs7-mime"


@@ -375,11 +388,13 @@ If not set, `default-directory' will be used."
 
 (defcustom mm-attachment-file-modes 384
   "Set the mode bits of saved attachments to this integer."
 
 (defcustom mm-attachment-file-modes 384
   "Set the mode bits of saved attachments to this integer."

+  :version "22.1"

   :type 'integer
   :group 'mime-display)
 
 (defcustom mm-external-terminal-program "xterm"
   "The program to start an external terminal."
   :type 'integer
   :group 'mime-display)
 
 (defcustom mm-external-terminal-program "xterm"
   "The program to start an external terminal."

+  :version "22.1"

   :type 'string
   :group 'mime-display)
 
   :type 'string
   :group 'mime-display)
 


@@ -412,6 +427,7 @@ If not set, `default-directory' will be used."
   "Option of verifying signed parts.
 `never', not verify; `always', always verify;
 `known', only verify known protocols.  Otherwise, ask user."
   "Option of verifying signed parts.
 `never', not verify; `always', always verify;
 `known', only verify known protocols.  Otherwise, ask user."

+  :version "22.1"

   :type '(choice (item always)
                 (item never)
                 (item :tag "only known protocols" known)
   :type '(choice (item always)
                 (item never)
                 (item :tag "only known protocols" known)


@@ -430,6 +446,7 @@ If not set, `default-directory' will be used."
   "Option of decrypting encrypted parts.
 `never', not decrypt; `always', always decrypt;
 `known', only decrypt known protocols.  Otherwise, ask user."
   "Option of decrypting encrypted parts.
 `never', not decrypt; `always', always decrypt;
 `known', only decrypt known protocols.  Otherwise, ask user."

+  :version "22.1"

   :type '(choice (item always)
                 (item never)
                 (item :tag "only known protocols" known)
   :type '(choice (item always)
                 (item never)
                 (item :tag "only known protocols" known)


@@ -439,21 +456,19 @@ If not set, `default-directory' will be used."
 (defvar mm-viewer-completion-map
   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
     (set-keymap-parent map minibuffer-local-completion-map)
 (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.")
 
     map)
   "Keymap for input viewer with completion.")
 

-;; Should we bind other key to minibuffer-complete-word?
-(define-key mm-viewer-completion-map " " 'self-insert-command)
-

 (defvar mm-viewer-completion-map
   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
     (set-keymap-parent map minibuffer-local-completion-map)
 (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.")
 
     map)
   "Keymap for input viewer with completion.")
 

-;; Should we bind other key to minibuffer-complete-word?
-(define-key mm-viewer-completion-map " " 'self-insert-command)
-

 ;;; The functions.
 
 (defun mm-alist-to-plist (alist)
 ;;; The functions.
 
 (defun mm-alist-to-plist (alist)


@@ -500,10 +515,10 @@ 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)))
 

-(defun mm-dissect-buffer (&optional no-strict-mime loose-mime)
+(defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)

   "Dissect the current buffer and return a list of MIME handles."
   (save-excursion
   "Dissect the current buffer and return a list of MIME handles."
   (save-excursion

-    (let (ct ctl type subtype cte cd description id result from)
+    (let (ct ctl type subtype cte cd description id result)

       (save-restriction
        (mail-narrow-to-head)
        (when (or no-strict-mime
       (save-restriction
        (mail-narrow-to-head)
        (when (or no-strict-mime


@@ -514,8 +529,9 @@ Postpone undisplaying of viewers for types in
                cte (mail-fetch-field "content-transfer-encoding")
                cd (mail-fetch-field "content-disposition")
                description (mail-fetch-field "content-description")
                cte (mail-fetch-field "content-transfer-encoding")
                cd (mail-fetch-field "content-disposition")
                description (mail-fetch-field "content-description")

-               from (mail-fetch-field "from")

                id (mail-fetch-field "content-id"))
                id (mail-fetch-field "content-id"))

+         (unless from
+               (setq from (mail-fetch-field "from")))

          ;; FIXME: In some circumstances, this code is running within
          ;; an unibyte macro.  mail-extract-address-components
          ;; creates unibyte buffers. This `if', though not a perfect
          ;; FIXME: In some circumstances, this code is running within
          ;; an unibyte macro.  mail-extract-address-components
          ;; creates unibyte buffers. This `if', though not a perfect


@@ -547,14 +563,14 @@ Postpone undisplaying of viewers for types in
             ;; what really needs to be done here is a way to link a
             ;; MIME handle back to it's parent MIME handle (in a multilevel
             ;; MIME article).  That would probably require changing
             ;; what really needs to be done here is a way to link a
             ;; MIME handle back to it's parent MIME handle (in a multilevel
             ;; MIME article).  That would probably require changing

-            ;; the mm-handle API so we simply store the multipart buffert
+            ;; the mm-handle API so we simply store the multipart buffer

             ;; name as a text property of the "multipart/whatever" string.
             (add-text-properties 0 (length (car ctl))
                                  (list 'buffer (mm-copy-to-buffer)
                                        'from from
                                        'start start)
                                  (car ctl))
             ;; name as a text property of the "multipart/whatever" string.
             (add-text-properties 0 (length (car ctl))
                                  (list 'buffer (mm-copy-to-buffer)
                                        'from from
                                        'start start)
                                  (car ctl))

-            (cons (car ctl) (mm-dissect-multipart ctl))))
+            (cons (car ctl) (mm-dissect-multipart ctl from))))

          (t
           (mm-possibly-verify-or-decrypt
            (mm-dissect-singlepart
          (t
           (mm-possibly-verify-or-decrypt
            (mm-dissect-singlepart


@@ -579,7 +595,7 @@ Postpone undisplaying of viewers for types in
     (mm-make-handle
      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 
     (mm-make-handle
      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 

-(defun mm-dissect-multipart (ctl)
+(defun mm-dissect-multipart (ctl from)

   (goto-char (point-min))
   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
         (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
   (goto-char (point-min))
   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
         (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))


@@ -596,7 +612,7 @@ Postpone undisplaying of viewers for types in
        (save-excursion
          (save-restriction
            (narrow-to-region start (point))
        (save-excursion
          (save-restriction
            (narrow-to-region start (point))

-           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
+           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))

       (end-of-line 2)
       (or (looking-at boundary)
          (forward-line 1))
       (end-of-line 2)
       (or (looking-at boundary)
          (forward-line 1))


@@ -605,7 +621,7 @@ Postpone undisplaying of viewers for types in
       (save-excursion
        (save-restriction
          (narrow-to-region start end)
       (save-excursion
        (save-restriction
          (narrow-to-region start end)

-         (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
+         (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))

     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 
 (defun mm-copy-to-buffer ()
     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 
 (defun mm-copy-to-buffer ()


@@ -616,7 +632,10 @@ Postpone undisplaying of viewers for types in
       (goto-char (point-min))
       (search-forward-regexp "^\n" nil t)
       (setq beg (point))
       (goto-char (point-min))
       (search-forward-regexp "^\n" nil t)
       (setq beg (point))

-      (set-buffer (generate-new-buffer " *mm*"))
+      (set-buffer
+       ;; Preserve the data's unibyteness (for url-insert-file-contents).
+       (let ((default-enable-multibyte-characters (mm-multibyte-p)))
+        (generate-new-buffer " *mm*")))

       (insert-buffer-substring obuf beg)
       (current-buffer))))
 
       (insert-buffer-substring obuf beg)
       (current-buffer))))
 


@@ -785,8 +804,7 @@ external if displayed external."
                                   (mm-mailcap-command
                                    method file (mm-handle-type handle)))
                     (if (buffer-live-p buffer)
                                   (mm-mailcap-command
                                    method file (mm-handle-type handle)))
                     (if (buffer-live-p buffer)

-                        (save-excursion
-                          (set-buffer buffer)
+                        (with-current-buffer buffer

                           (buffer-string))))
                 (progn
                   (ignore-errors (delete-file file))
                           (buffer-string))))
                 (progn
                   (ignore-errors (delete-file file))


@@ -798,11 +816,32 @@ external if displayed external."
            (let ((command (mm-mailcap-command
                            method file (mm-handle-type handle))))
              (unwind-protect
            (let ((command (mm-mailcap-command
                            method file (mm-handle-type handle))))
              (unwind-protect

-                 (start-process "*display*"
-                                (setq buffer
-                                      (generate-new-buffer " *mm*"))
-                                shell-file-name
-                                shell-command-switch command)
+                 (progn
+                   (start-process "*display*"
+                                  (setq buffer
+                                        (generate-new-buffer " *mm*"))
+                                  shell-file-name
+                                  shell-command-switch command)
+                   (set-process-sentinel
+                    (get-buffer-process buffer)
+                    `(lambda (process state)
+                       (when (eq 'exit (process-status process))
+                         ;; Don't use `ignore-errors'.
+                         (condition-case nil
+                             (delete-file ,file)
+                           (error))
+                         (condition-case nil
+                             (delete-directory ,(file-name-directory file))
+                           (error))
+                         (condition-case nil
+                             (kill-buffer ,buffer)
+                           (error))
+                         (condition-case nil
+                             ,(macroexpand (list 'mm-handle-set-undisplayer
+                                                 (list 'quote handle)
+                                                 nil))
+                           (error))
+                         (message "Displaying %s...done" ,command)))))

                (mm-handle-set-external-undisplayer
                 handle (cons file buffer)))
              (message "Displaying %s..." command))
                (mm-handle-set-external-undisplayer
                 handle (cons file buffer)))
              (message "Displaying %s..." command))


@@ -1014,27 +1053,16 @@ external if displayed external."
 
 (defun mm-insert-part (handle)
   "Insert the contents of HANDLE in the current buffer."
 
 (defun mm-insert-part (handle)
   "Insert the contents of HANDLE in the current buffer."

-  (let ((cur (current-buffer)))
-    (save-excursion
-      (if (member (mm-handle-media-supertype handle) '("text" "message"))
-         (with-temp-buffer
-           (insert-buffer-substring (mm-handle-buffer handle))
-           (prog1
-               (mm-decode-content-transfer-encoding
-                (mm-handle-encoding handle)
-                (mm-handle-media-type handle))
-             (let ((temp (current-buffer)))
-               (set-buffer cur)
-               (insert-buffer-substring temp))))
-       (mm-with-unibyte-buffer
-         (insert-buffer-substring (mm-handle-buffer handle))
-         (prog1
-             (mm-decode-content-transfer-encoding
-              (mm-handle-encoding handle)
-              (mm-handle-media-type handle))
-           (let ((temp (current-buffer)))
-             (set-buffer cur)
-             (insert-buffer-substring temp))))))))
+  (save-excursion
+    (insert
+     (cond ((eq (mail-content-type-get (mm-handle-type handle) 'charset)
+               'gnus-decoded)
+           (with-current-buffer (mm-handle-buffer handle)
+             (buffer-string)))
+          ((mm-multibyte-p)
+           (mm-string-as-multibyte (mm-get-part handle)))
+          (t
+           (mm-get-part handle))))))

 
 (defun mm-file-name-delete-whitespace (file-name)
   "Remove all whitespace characters from FILE-NAME."
 
 (defun mm-file-name-delete-whitespace (file-name)
   "Remove all whitespace characters from FILE-NAME."


@@ -1074,8 +1102,9 @@ string if you do not like underscores."
   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
   (gnus-replace-in-string filename "^[.-]+" ""))
 
   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
   (gnus-replace-in-string filename "^[.-]+" ""))
 

-(defun mm-save-part (handle)
-  "Write HANDLE to a file."
+(defun mm-save-part (handle &optional prompt)
+  "Write HANDLE to a file.
+PROMPT overrides the default one used to ask user for a file name."

   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
         (filename (mail-content-type-get
                    (mm-handle-disposition handle) 'filename))
   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
         (filename (mail-content-type-get
                    (mm-handle-disposition handle) 'filename))


@@ -1085,7 +1114,7 @@ string if you do not like underscores."
                                        (file-name-nondirectory filename))))
     (setq file
          (mm-with-multibyte
                                        (file-name-nondirectory filename))))
     (setq file
          (mm-with-multibyte

-           (read-file-name "Save MIME part to: "
+           (read-file-name (or prompt "Save MIME part to: ")

                            (or mm-default-directory default-directory)
                            nil nil (or filename name ""))))
     (setq mm-default-directory (file-name-directory file))
                            (or mm-default-directory default-directory)
                            nil nil (or filename name ""))))
     (setq mm-default-directory (file-name-directory file))


@@ -1475,5 +1504,5 @@ If RECURSIVE, search recursively."
 
 (provide 'mm-decode)
 
 
 (provide 'mm-decode)
 

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

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