(article-transform-date): Fix infinite recursion.

[gnus] / lisp / mm-decode.el

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index 8bc659f..d7bc882 100644 (file)
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,7 +1,6 @@
 ;;; 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, 2008, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 1998-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,7 +23,7 @@
 
 ;;; Code:
 
 
 ;;; Code:
 

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

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


@@ -105,10 +104,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)


@@ -117,6 +114,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;


@@ -124,9 +123,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)


@@ -135,10 +136,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


@@ -239,12 +236,16 @@ before the external MIME handler is invoked."
      (lambda (handle) (fboundp 'diff-mode)))
     ("application/emacs-lisp" mm-display-elisp-inline identity)
     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
      (lambda (handle) (fboundp 'diff-mode)))
     ("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)


@@ -316,7 +317,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)


@@ -369,8 +371,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


@@ -623,7 +629,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)))


@@ -665,7 +671,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."


@@ -695,13 +701,14 @@ Postpone undisplaying of viewers for types in
 (autoload 'mailcap-parse-mailcaps "mailcap")
 (autoload 'mailcap-mime-info "mailcap")
 
 (autoload 'mailcap-parse-mailcaps "mailcap")
 (autoload 'mailcap-mime-info "mailcap")
 

-(defun mm-display-part (handle &optional no-default)
+(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")


@@ -1148,13 +1155,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))
 


@@ -1247,9 +1256,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? "


@@ -1258,11 +1275,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)


@@ -1273,8 +1290,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


@@ -1300,27 +1318,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
-         (gnus-read-shell-command
-           "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))

-                  (completing-read "Viewer: " methods))))
+                  (gnus-completing-read "Viewer" methods))))

     (when (string= method "")
       (error "No method given"))
     (if (string-match "^[^% \t]+$" method)
     (when (string= method "")
       (error "No method given"))
     (if (string-match "^[^% \t]+$" method)


@@ -1351,13 +1372,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."


@@ -1472,7 +1499,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)))


@@ -1553,7 +1580,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.


@@ -1568,7 +1595,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


@@ -1667,7 +1694,64 @@ 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)
+            (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))))))))
+

 (provide 'mm-decode)
 
 (provide 'mm-decode)
 

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

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