X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/67f3ad67ee317226cb5d1bb139de0cfd883fdc5e..341dd15a7bd9d0b4adff846e94289b3e1877eed1:/lisp/gnus/mm-decode.el

diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el
index 028855ab34..56258b96b6 100644
--- a/lisp/gnus/mm-decode.el
+++ b/lisp/gnus/mm-decode.el
@@ -1,7 +1,7 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
 
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -9,7 +9,7 @@
 
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
 ;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
@@ -26,14 +26,18 @@
 
 ;;; Code:
 
+;; For Emacs < 22.2.
+(eval-and-compile
+  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
+
 (require 'mail-parse)
 (require 'mailcap)
 (require 'mm-bodies)
+(require 'gnus-util)
 (eval-when-compile (require 'cl)
 		   (require 'term))
 
 (eval-and-compile
-  (autoload 'executable-find "executable")
   (autoload 'mm-inline-partial "mm-partial")
   (autoload 'mm-inline-external-body "mm-extern")
   (autoload 'mm-extern-cache-contents "mm-extern")
@@ -102,31 +106,33 @@
 	 ,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 ((executable-find "w3m")
+	 (if (locate-library "w3m")
+	     'w3m
+	   'w3m-standalone))
 	((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:
-`w3'   : use Emacs/W3;
 `w3m'  : use emacs-w3m;
 `w3m-standalone': use w3m;
 `links': use links;
 `lynx' : use lynx;
+`w3'   : use Emacs/W3;
 `html2text' : use html2text;
-nil    : use external viewer."
-  :version "22.1"
+nil    : use external viewer (default web browser)."
+  :version "23.0" ;; No Gnus
   :type '(choice (const w3)
-		 (const w3m)
-		 (const w3m-standalone)
+		 (const w3m :tag "emacs-w3m")
+		 (const w3m-standalone :tag "standalone w3m" )
 		 (const links)
 		 (const lynx)
 		 (const html2text)
-		 (const nil)
+		 (const nil :tag "External viewer")
 		 (function))
   :group 'mime-display)
 
@@ -229,8 +235,12 @@ before the external MIME handler is invoked."
        ;; makes it possible to install another package which provides an
        ;; alternative implementation of diff-mode.  --Stef
        (fboundp 'diff-mode)))
+    ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
+    ("text/x-diff" mm-display-patch-inline
+     (lambda (handle) (fboundp 'diff-mode)))
     ("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)
@@ -299,9 +309,9 @@ when selecting a different article."
   :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/.*"
-    "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"
@@ -364,20 +374,34 @@ enables you to choose manually one of two types those mails include."
   :type 'boolean
   :group 'mime-display)
 
-(defvar mm-file-name-rewrite-functions
+(defcustom mm-file-name-rewrite-functions
   '(mm-file-name-delete-control mm-file-name-delete-gotchas)
-  "*List of functions used for rewriting file names of MIME parts.
+  "List of functions used for rewriting file names of MIME parts.
 Each function takes a file name as input and returns a file name.
 
-Ready-made functions include
-`mm-file-name-delete-control'
-`mm-file-name-delete-gotchas'
-`mm-file-name-delete-whitespace',
-`mm-file-name-trim-whitespace',
-`mm-file-name-collapse-whitespace',
-`mm-file-name-replace-whitespace',
-`capitalize', `downcase', `upcase', and
-`upcase-initials'.")
+Ready-made functions include `mm-file-name-delete-control',
+`mm-file-name-delete-gotchas' (you should not remove these two
+functions), `mm-file-name-delete-whitespace',
+`mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace',
+`mm-file-name-replace-whitespace', `capitalize', `downcase',
+`upcase', and `upcase-initials'."
+  :type '(list (set :inline t
+		    (const mm-file-name-delete-control)
+		    (const mm-file-name-delete-gotchas)
+		    (const mm-file-name-delete-whitespace)
+		    (const mm-file-name-trim-whitespace)
+		    (const mm-file-name-collapse-whitespace)
+		    (const mm-file-name-replace-whitespace)
+		    (const capitalize)
+		    (const downcase)
+		    (const upcase)
+		    (const upcase-initials)
+	       (repeat :inline t
+		       :tag "Function"
+		       function)))
+  :version "23.1" ;; No Gnus
+  :group 'mime-display)
+
 
 (defvar mm-path-name-rewrite-functions nil
   "*List of functions for rewriting the full file names of MIME parts.
@@ -436,7 +460,11 @@ If not set, `default-directory' will be used."
 (defcustom mm-verify-option 'never
   "Option of verifying signed parts.
 `never', not verify; `always', always verify;
-`known', only verify known protocols.  Otherwise, ask user."
+`known', only verify known protocols.  Otherwise, ask user.
+
+When set to `always' or `known', you should add
+\"multipart/signed\" to `gnus-buttonized-mime-types' to see
+result of the verification."
   :version "22.1"
   :type '(choice (item always)
 		 (item never)
@@ -547,16 +575,15 @@ Postpone undisplaying of viewers for types in
 	  ;; creates unibyte buffers. This `if', though not a perfect
 	  ;; solution, avoids most of them.
 	  (if from
-	      (setq from (cadr (mail-extract-address-components from))))))
-      (when cte
-	(setq cte (mail-header-strip cte)))
+	      (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
 	   (list mm-dissect-default-type)
-	   (and cte (intern (downcase (mail-header-remove-whitespace
-				       (mail-header-remove-comments
-					cte)))))
+	   (and cte (intern (downcase (mail-header-strip cte))))
 	   no-strict-mime
 	   (and cd (mail-header-parse-content-disposition cd))
 	   description)
@@ -589,9 +616,7 @@ Postpone undisplaying of viewers for types in
 	   (mm-possibly-verify-or-decrypt
 	    (mm-dissect-singlepart
 	     ctl
-	     (and cte (intern (downcase (mail-header-remove-whitespace
-					 (mail-header-remove-comments
-					  cte)))))
+	     (and cte (intern (downcase (mail-header-strip cte))))
 	     no-strict-mime
 	     (and cd (mail-header-parse-content-disposition cd))
 	     description id)
@@ -641,15 +666,16 @@ Postpone undisplaying of viewers for types in
 
 (defun mm-copy-to-buffer ()
   "Copy the contents of the current buffer to a fresh buffer."
-    (let ((obuf (current-buffer))
-	  beg)
-      (goto-char (point-min))
-      (search-forward-regexp "^\n" nil t)
-      (setq beg (point))
+  (let ((obuf (current-buffer))
+        (mb (mm-multibyte-p))
+        beg)
+    (goto-char (point-min))
+    (search-forward-regexp "^\n" nil t)
+    (setq beg (point))
     (with-current-buffer
-       ;; Preserve the data's unibyteness (for url-insert-file-contents).
-       (let ((default-enable-multibyte-characters (mm-multibyte-p)))
-          (generate-new-buffer " *mm*"))
+          (generate-new-buffer " *mm*")
+      ;; Preserve the data's unibyteness (for url-insert-file-contents).
+      (mm-set-buffer-multibyte mb)
       (insert-buffer-substring obuf beg)
       (current-buffer))))
 
@@ -721,6 +747,8 @@ external if displayed external."
 		(mm-display-external
 		 handle 'mailcap-save-binary-file)))))))))
 
+(declare-function gnus-configure-windows "gnus-win" (setting &optional force))
+
 (defun mm-display-external (handle method)
   "Display HANDLE using METHOD."
   (let ((outbuf (current-buffer)))
@@ -732,6 +760,7 @@ external if displayed external."
 		  (set-buffer (generate-new-buffer " *mm*"))
 		  (setq method nil))
 	      (mm-insert-part handle)
+	      (mm-add-meta-html-tag handle)
 	      (let ((win (get-buffer-window cur t)))
 		(when win
 		  (select-window win)))
@@ -755,6 +784,7 @@ external if displayed external."
 		  (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
@@ -769,7 +799,7 @@ external if displayed external."
 	       (copiousoutput (assoc "copiousoutput" mime-info))
 	       file buffer)
 	  ;; We create a private sub-directory where we store our files.
-	  (set-file-modes dir 448)
+	  (set-file-modes dir #o700)
 	  (if filename
 	      (setq file (expand-file-name
 			  (gnus-map-function mm-file-name-rewrite-functions
@@ -789,6 +819,10 @@ external if displayed external."
 					    nil suffix))))
 	  (let ((coding-system-for-write mm-binary-coding-system))
 	    (write-region (point-min) (point-max) file nil 'nomesg))
+	  ;; The file is deleted after the viewer exists.  If the users edits
+	  ;; the file, changes will be lost.  Set file to read-only to make it
+	  ;; clear.
+	  (set-file-modes file #o400)
 	  (message "Viewing with %s" method)
 	  (cond
 	   (needsterm
@@ -883,7 +917,7 @@ external if displayed external."
 			  ;; a vector in Emacs but is a list in XEmacs)
 			  ;; requires that it is lexically scoped.
 			  (timer (run-at-time 2.0 nil 'ignore)))
-		       (if (boundp 'itimer-list)
+		       (if (featurep 'xemacs)
 			   (lambda (process state)
 			     (when (eq 'exit (process-status process))
 			       (if (memq timer itimer-list)
@@ -922,16 +956,16 @@ external if displayed external."
 	    (string= total "'%s'")
 	    (string= total "\"%s\""))
 	(setq uses-stdin nil)
-	(push (mm-quote-arg
+	(push (shell-quote-argument
 	       (gnus-map-function mm-path-name-rewrite-functions file)) out))
        ((string= total "%t")
-	(push (mm-quote-arg (car type-list)) out))
+	(push (shell-quote-argument (car type-list)) out))
        (t
-	(push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
+	(push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
     (push (substring method beg (length method)) out)
     (when uses-stdin
       (push "<" out)
-      (push (mm-quote-arg
+      (push (shell-quote-argument
 	     (gnus-map-function mm-path-name-rewrite-functions file))
 	    out))
     (mapconcat 'identity (nreverse out) "")))
@@ -978,7 +1012,8 @@ external if displayed external."
 	(cond
 	 ;; Internally displayed part.
 	 ((mm-annotationp object)
-	  (delete-annotation object))
+          (if (featurep 'xemacs)
+              (delete-annotation object)))
 	 ((or (functionp object)
 	      (and (listp object)
 		   (eq (car object) 'lambda)))
@@ -1100,17 +1135,15 @@ in HANDLE."
 
 (defmacro mm-with-part (handle &rest forms)
   "Run FORMS in the temp buffer containing the contents of HANDLE."
-  `(let* ((handle ,handle)
-	  ;; The multibyteness of the temp buffer should be turned on
-	  ;; if inserting a multibyte string.  Contrarily, the buffer's
-	  ;; multibyteness should be off if inserting a unibyte string,
-	  ;; especially if a string contains 8bit data.
-	  (default-enable-multibyte-characters
-	    (with-current-buffer (mm-handle-buffer handle)
-	      (mm-multibyte-p))))
+  ;; 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))
      (with-temp-buffer
-       (insert-buffer-substring (mm-handle-buffer handle))
        (mm-disable-multibyte)
+       (insert-buffer-substring (mm-handle-buffer handle))
        (mm-decode-content-transfer-encoding
 	(mm-handle-encoding handle)
 	(mm-handle-media-type handle))
@@ -1136,16 +1169,26 @@ are ignored."
   "Insert the contents of HANDLE in the current buffer.
 If NO-CACHE is non-nil, cached contents of a message/external-body part
 are ignored."
-  (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-to-multibyte (mm-get-part handle no-cache)))
-	   (t
-	    (mm-get-part handle no-cache))))))
+  (let ((text (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-to-multibyte (mm-get-part handle no-cache)))
+		    (t
+		     (mm-get-part handle no-cache)))))
+    (save-restriction
+      (widen)
+      (goto-char
+       (prog1
+	   (point)
+	 (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face)
+		      'mm-uu-extract)
+		  (eq (get-char-property 0 'face text) 'mm-uu-extract))
+	     ;; Separate the extracted parts that have the same faces.
+	     (insert "\n" text)
+	   (insert text)))))))
 
 (defun mm-file-name-delete-whitespace (file-name)
   "Remove all whitespace characters from FILE-NAME."
@@ -1185,8 +1228,9 @@ string if you do not like underscores."
   (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 ((filename (or (mail-content-type-get
 		       (mm-handle-disposition handle) 'filename)
 		      (mail-content-type-get
@@ -1196,10 +1240,9 @@ string if you do not like underscores."
       (setq filename (gnus-map-function mm-file-name-rewrite-functions
 					(file-name-nondirectory filename))))
     (setq file
-	  (mm-with-multibyte
-	   (read-file-name "Save MIME part to: "
-			   (or mm-default-directory default-directory)
-			   nil nil (or filename ""))))
+          (read-file-name (or prompt "Save MIME part to: ")
+                          (or mm-default-directory default-directory)
+                          nil nil (or filename "")))
     (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? "
@@ -1208,20 +1251,46 @@ string if you do not like underscores."
 	   (mm-save-part-to-file handle file)
 	   file))))
 
+(defun mm-add-meta-html-tag (handle &optional charset)
+  "Add meta html tag to specify CHARSET of HANDLE in the current buffer.
+CHARSET defaults to the one HANDLE specifies.  Existing meta tag that
+specifies charset will not be modified.  Return t if meta tag is added
+or replaced."
+  (when (equal (mm-handle-media-type handle) "text/html")
+    (when (or charset
+	      (setq charset (mail-content-type-get (mm-handle-type handle)
+						   'charset)))
+      (setq charset (format "\
+<meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" charset))
+      (let ((case-fold-search t))
+	(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)
+		     (string-match "\\`html\\'" (match-string 1)))
+		;; Don't modify existing meta tag.
+		nil
+	      ;; Replace it with the one specifying charset.
+	      (replace-match charset)
+	      t)
+	  (if (re-search-forward "<head>\\s-*" nil t)
+	      (insert charset "\n")
+	    (re-search-forward "<html\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
+	    (insert "<head>\n" charset "\n</head>\n"))
+	  t)))))
+
 (defun mm-save-part-to-file (handle file)
   (mm-with-unibyte-buffer
     (mm-insert-part handle)
-    (let ((coding-system-for-write 'binary)
-	  (current-file-modes (default-file-modes))
+    (mm-add-meta-html-tag handle)
+    (let ((current-file-modes (default-file-modes)))
+      (set-default-file-modes mm-attachment-file-modes)
+      (unwind-protect
 	  ;; Don't re-compress .gz & al.  Arguably we should make
 	  ;; `file-name-handler-alist' nil, but that would chop
 	  ;; ange-ftp, which is reasonable to use here.
-	  (inhibit-file-name-operation 'write-region)
-	  (inhibit-file-name-handlers
-	   (cons 'jka-compr-handler inhibit-file-name-handlers)))
-      (set-default-file-modes mm-attachment-file-modes)
-      (unwind-protect
-	  (write-region (point-min) (point-max) file)
+	  (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)
@@ -1231,6 +1300,7 @@ string if you do not like underscores."
 	  (read-string "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)))))
 
@@ -1345,34 +1415,35 @@ be determined."
 	    (mm-handle-set-cache handle spec))))))
 
 (defun mm-create-image-xemacs (type)
-  (cond
-   ((equal type "xbm")
-    ;; xbm images require special handling, since
-    ;; the only way to create glyphs from these
-    ;; (without a ton of work) is to write them
-    ;; out to a file, and then create a file
-    ;; specifier.
-    (let ((file (mm-make-temp-file
-		 (expand-file-name "emm" mm-tmp-directory)
-		 nil ".xbm")))
-      (unwind-protect
-	  (progn
-	    (write-region (point-min) (point-max) file)
-	    (make-glyph (list (cons 'x file))))
-	(ignore-errors
-	  (delete-file file)))))
-   (t
-    (make-glyph
-     (vector
-      (or (mm-image-type-from-buffer)
-	  (intern type))
-      :data (buffer-string))))))
+  (when (featurep 'xemacs)
+    (cond
+     ((equal type "xbm")
+      ;; xbm images require special handling, since
+      ;; the only way to create glyphs from these
+      ;; (without a ton of work) is to write them
+      ;; out to a file, and then create a file
+      ;; specifier.
+      (let ((file (mm-make-temp-file
+		   (expand-file-name "emm" mm-tmp-directory)
+		   nil ".xbm")))
+	(unwind-protect
+	    (progn
+	      (write-region (point-min) (point-max) file)
+	      (make-glyph (list (cons 'x file))))
+	  (ignore-errors
+	    (delete-file file)))))
+     (t
+      (make-glyph
+       (vector
+	(or (mm-image-type-from-buffer)
+	    (intern type))
+	:data (buffer-string)))))))
 
 (defun mm-image-fit-p (handle)
   "Say whether the image in HANDLE will fit the current window."
   (let ((image (mm-get-image handle)))
     (or (not image)
-	(if (fboundp 'glyph-width)
+	(if (featurep 'xemacs)
 	    ;; XEmacs' glyphs can actually tell us about their width, so
 	    ;; lets be nice and smart about them.
 	    (or mm-inline-large-images
@@ -1470,6 +1541,8 @@ If RECURSIVE, search recursively."
     (put-text-property 0 (length (car handle)) parameter value
 		       (car handle))))
 
+(autoload 'mm-view-pkcs7 "mm-view")
+
 (defun mm-possibly-verify-or-decrypt (parts ctl)
   (let ((type (car ctl))
 	(subtype (cadr (split-string (car ctl) "/")))
@@ -1517,7 +1590,7 @@ If RECURSIVE, search recursively."
 			   (format "protocol=%s" protocol))))))
 	(save-excursion
 	  (if func
-	      (funcall func parts ctl)
+	      (setq parts (funcall func parts ctl))
 	    (mm-set-handle-multipart-parameter
 	     mm-security-handle 'gnus-details
 	     (format "Unknown sign protocol (%s)" protocol))))))