X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=5f9cba6ff75fa9092cc1e2855aca68a8e0fb096e;hb=f7023e9df2a3d483f5cbd4e02afc7a6b6ed605cb;hp=8614d4c193aa032b5ab1a54f0faaaa5070580b52;hpb=3dd0d75daea81f18f28c1363db77a29627376882;p=elisp%2Fgnus.git-

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index 8614d4c..5f9cba6 100644
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,5 +1,5 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -22,14 +22,6 @@
 
 ;;; Commentary:
 
-;; Jaap-Henk Hoepman (jhh@xs4all.nl):
-;;
-;; Added support for delayed destroy of external MIME viewers. All external
-;; viewers for mime types in mm-keep-viewer-alive-types will remain active
-;; after switching articles or groups, and will only be removed when exiting
-;; gnus.
-;;
-
 ;;; Code:
 
 (require 'mail-parse)
@@ -39,6 +31,7 @@
 		   (require 'term))
 
 (eval-and-compile
+  (autoload 'executable-find "executable")
   (autoload 'mm-inline-partial "mm-partial")
   (autoload 'mm-inline-external-body "mm-extern")
   (autoload 'mm-insert-inline "mm-view"))
@@ -103,6 +96,59 @@
   `(list ,buffer ,type ,encoding ,undisplayer
 	 ,disposition ,description ,cache ,id))
 
+(defcustom mm-text-html-renderer
+  (cond ((locate-library "w3") 'w3)
+	((locate-library "w3m") 'w3m)
+	((executable-find "links") 'links)
+	((executable-find "lynx") 'lynx)
+	(t 'html2text))
+  "Render of HTML contents.
+It is one of defined renderer types, or a rendering function.
+The defined renderer types are:
+`w3'   : using Emacs/W3;
+`w3m'  : using emacs-w3m;
+`links': using links;
+`lynx' : using lynx;
+`html2text' : using html2text;
+`nil'  : using external viewer."
+  :type '(choice (const w3)
+		 (const w3m)
+		 (const links)
+		 (const lynx)
+		 (const html2text)
+		 (const nil)
+		 (function))
+  :version "21.3"
+  :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 the HTML contents
+with <img> tags.  It has no effect on Emacs/w3.  See also
+the documentation for the option `mm-w3m-safe-url-regexp'."
+  :type 'boolean
+  :group 'mime-display)
+
+(defcustom mm-w3m-safe-url-regexp "\\`cid:"
+  "Regexp that matches safe url names.  Some HTML mails might have a
+trick of spammers using <img> tags.  It is likely to be intended to
+verify whether you have read the mail.  You can prevent your personal
+informations from leaking by setting this to the regexp which matches
+the safe url names.  The value of the variable `w3m-safe-url-regexp'
+will be bound with this value.  You may set this value to nil if you
+consider all the urls to be safe."
+  :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 'boolean
+  :group 'mime-display)
+
 (defcustom mm-inline-media-tests
   '(("image/jpeg"
      mm-inline-image
@@ -151,12 +197,14 @@
      (lambda (handle)
        (locate-library "diff-mode")))
     ("application/emacs-lisp" mm-display-elisp-inline identity)
+    ("application/x-emacs-lisp" mm-display-elisp-inline identity)
     ("text/html"
-     mm-inline-text
+     mm-inline-text-html
      (lambda (handle)
-       (locate-library "w3")))
+       (or mm-inline-text-html-renderer
+	   mm-text-html-renderer)))
     ("text/x-vcard"
-     mm-inline-text
+     mm-inline-text-vcard
      (lambda (handle)
        (or (featurep 'vcard)
 	   (locate-library "vcard"))))
@@ -177,8 +225,8 @@
     ("application/pgp-signature" ignore identity)
     ("application/x-pkcs7-signature" ignore identity)
     ("application/pkcs7-signature" ignore identity)
-    ("application/x-pkcs7-mime" mm-view-pkcs7 identity)
-    ("application/pkcs7-mime" mm-view-pkcs7 identity)
+    ("application/x-pkcs7-mime" ignore identity)
+    ("application/pkcs7-mime" ignore identity)
     ("multipart/alternative" ignore identity)
     ("multipart/mixed" ignore identity)
     ("multipart/related" ignore identity)
@@ -196,6 +244,7 @@
 (defcustom mm-inlined-types
   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
     "message/partial" "message/external-body" "application/emacs-lisp"
+    "application/x-emacs-lisp"
     "application/pgp-signature" "application/x-pkcs7-signature"
     "application/pkcs7-signature" "application/x-pkcs7-mime"
     "application/pkcs7-mime")
@@ -217,7 +266,8 @@ when selecting a different article."
   '("text/plain" "text/enriched" "text/richtext" "text/html"
     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
     "message/rfc822" "text/x-patch" "application/pgp-signature"
-    "application/emacs-lisp" "application/x-pkcs7-signature"
+    "application/emacs-lisp" "application/x-emacs-lisp"
+    "application/x-pkcs7-signature"
     "application/pkcs7-signature" "application/x-pkcs7-mime"
     "application/pkcs7-mime")
   "A list of MIME types to be displayed automatically."
@@ -226,7 +276,9 @@ when selecting a different article."
 
 (defcustom mm-attachment-override-types '("text/x-vcard"
 					  "application/pkcs7-mime"
-					  "application/x-pkcs7-mime")
+					  "application/x-pkcs7-mime"
+					  "application/pkcs7-signature"
+					  "application/x-pkcs7-signature")
   "Types to have \"attachment\" ignored if they can be displayed inline."
   :type '(repeat string)
   :group 'mime-display)
@@ -279,13 +331,21 @@ Ready-made functions include
 `capitalize', `downcase', `upcase', and
 `upcase-initials'.")
 
+(defvar mm-path-name-rewrite-functions nil
+  "*List of functions used for rewriting path names of MIME parts.
+This is used when viewing parts externally , and is meant for
+transforming the path name so that non-compliant programs can
+find the file where it's saved.
+
+Each function takes a file name as input and returns a file name.")
+
 (defvar mm-file-name-replace-whitespace nil
   "String used for replacing whitespace characters; default is `\"_\"'.")
 
 (defcustom mm-default-directory nil
   "The default directory where mm will save files.
 If not set, `default-directory' will be used."
-  :type 'directory
+  :type '(choice directory (const :tag "Default" nil))
   :group 'mime-display)
 
 (defcustom mm-external-terminal-program "xterm"
@@ -406,16 +466,18 @@ for types in mm-keep-viewer-alive-types."
     (mm-handle-set-undisplayer handle function)))
 
 (defun mm-destroy-postponed-undisplay-list ()
-  (message "Destroying external MIME viewers")
-  (mm-destroy-parts mm-postponed-undisplay-list))
+  (when mm-postponed-undisplay-list
+    (message "Destroying external MIME viewers")
+    (mm-destroy-parts mm-postponed-undisplay-list)))
 
-(defun mm-dissect-buffer (&optional no-strict-mime)
+(defun mm-dissect-buffer (&optional no-strict-mime loose-mime)
   "Dissect the current buffer and return a list of MIME handles."
   (save-excursion
     (let (ct ctl type subtype cte cd description id result from)
       (save-restriction
 	(mail-narrow-to-head)
 	(when (or no-strict-mime
+		  loose-mime
 		  (mail-fetch-field "mime-version"))
 	  (setq ct (mail-fetch-field "content-type")
 		ctl (ignore-errors (mail-header-parse-content-type ct))
@@ -468,14 +530,17 @@ for types in mm-keep-viewer-alive-types."
 				  (car ctl))
 	     (cons (car ctl) (mm-dissect-multipart ctl))))
 	  (t
-	   (mm-dissect-singlepart
-	    ctl
-	    (and cte (intern (downcase (mail-header-remove-whitespace
-					(mail-header-remove-comments
-					 cte)))))
-	    no-strict-mime
-	    (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
-	    description id))))
+	   (mm-possibly-verify-or-decrypt
+	    (mm-dissect-singlepart
+	     ctl
+	     (and cte (intern (downcase (mail-header-remove-whitespace
+					 (mail-header-remove-comments
+					  cte)))))
+	     no-strict-mime
+	     (and cd (ignore-errors
+		       (mail-header-parse-content-disposition cd)))
+	     description id)
+	    ctl))))
 	(when id
 	  (when (string-match " *<\\(.*\\)> *" id)
 	    (setq id (match-string 1 id)))
@@ -516,7 +581,9 @@ for types in mm-keep-viewer-alive-types."
 	  (save-restriction
 	    (narrow-to-region start (point))
 	    (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
-      (forward-line 2)
+      (end-of-line 2)
+      (or (looking-at boundary)
+	  (forward-line 1))
       (setq start (point)))
     (when (and start (< start end))
       (save-excursion
@@ -611,9 +678,13 @@ external if displayed external."
 		  (mm-handle-set-undisplayer handle mm)))))
 	;; The function is a string to be executed.
 	(mm-insert-part handle)
-	(let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
-	       (filename (mail-content-type-get
-			  (mm-handle-disposition handle) 'filename))
+	(let* ((dir (mm-make-temp-file
+		     (expand-file-name "emm." mm-tmp-directory) 'dir))
+	       (filename (or
+			  (mail-content-type-get
+			   (mm-handle-disposition handle) 'filename)
+			  (mail-content-type-get
+			   (mm-handle-type handle) 'name)))
 	       (mime-info (mailcap-mime-info
 			   (mm-handle-media-type handle) t))
 	       (needsterm (or (assoc "needsterm" mime-info)
@@ -621,83 +692,86 @@ external if displayed external."
 	       (copiousoutput (assoc "copiousoutput" mime-info))
 	       file buffer)
 	  ;; We create a private sub-directory where we store our files.
-	  (make-directory dir)
 	  (set-file-modes dir 448)
 	  (if filename
-	      (setq file (expand-file-name (file-name-nondirectory filename)
-					   dir))
-	    (setq file (make-temp-name (expand-file-name "mm." dir))))
+	      (setq file (expand-file-name
+			  (gnus-map-function mm-file-name-rewrite-functions
+					     (file-name-nondirectory filename))
+			  dir))
+	    (setq file (mm-make-temp-file (expand-file-name "mm." dir))))
 	  (let ((coding-system-for-write mm-binary-coding-system))
 	    (write-region (point-min) (point-max) file nil 'nomesg))
 	  (message "Viewing with %s" method)
-	  (cond (needsterm
-		 (unwind-protect
-		     (if window-system
-			 (start-process "*display*" nil
-					mm-external-terminal-program
-					"-e" shell-file-name
-					shell-command-switch
-					(mm-mailcap-command
-					 method file (mm-handle-type handle)))
-		       (require 'term)
-		       (require 'gnus-win)
-		       (set-buffer
-			(setq buffer
-			      (make-term "display"
-					 shell-file-name
-					 nil
-					 shell-command-switch
-					 (mm-mailcap-command
-					  method file
-					  (mm-handle-type handle)))))
-		       (term-mode)
-		       (term-char-mode)
-		       (set-process-sentinel
-			(get-buffer-process buffer)
-			`(lambda (process state)
-			   (if (eq 'exit (process-status process))
-			       (gnus-configure-windows
-				',gnus-current-window-configuration))))
-		       (gnus-configure-windows 'display-term))
-		   (mm-handle-set-external-undisplayer handle (cons file buffer)))
-		 (message "Displaying %s..." (format method file))
-		 'external)
-		(copiousoutput
-		 (with-current-buffer outbuf
-		   (forward-line 1)
-		   (mm-insert-inline
-		    handle
-		    (unwind-protect
-			(progn
-			  (call-process shell-file-name nil
-					(setq buffer
-					      (generate-new-buffer " *mm*"))
-					nil
-					shell-command-switch
-					(mm-mailcap-command
-					 method file (mm-handle-type handle)))
-			  (if (buffer-live-p buffer)
-			      (save-excursion
-				(set-buffer buffer)
-				(buffer-string))))
-		      (progn
-			(ignore-errors (delete-file file))
-			(ignore-errors (delete-directory
-					(file-name-directory file)))
-			(ignore-errors (kill-buffer buffer))))))
-		 'inline)
-		(t
-		 (unwind-protect
-		     (start-process "*display*"
-				    (setq buffer
-					  (generate-new-buffer " *mm*"))
+	  (cond
+	   (needsterm
+	    (unwind-protect
+		(if window-system
+		    (start-process "*display*" nil
+				   mm-external-terminal-program
+				   "-e" shell-file-name
+				   shell-command-switch
+				   (mm-mailcap-command
+				    method file (mm-handle-type handle)))
+		  (require 'term)
+		  (require 'gnus-win)
+		  (set-buffer
+		   (setq buffer
+			 (make-term "display"
 				    shell-file-name
+				    nil
 				    shell-command-switch
 				    (mm-mailcap-command
-				     method file (mm-handle-type handle)))
-		   (mm-handle-set-external-undisplayer handle (cons file buffer)))
-		 (message "Displaying %s..." (format method file))
-		 'external)))))))
+				     method file
+				     (mm-handle-type handle)))))
+		  (term-mode)
+		  (term-char-mode)
+		  (set-process-sentinel
+		   (get-buffer-process buffer)
+		   `(lambda (process state)
+		      (if (eq 'exit (process-status process))
+			  (gnus-configure-windows
+			   ',gnus-current-window-configuration))))
+		  (gnus-configure-windows 'display-term))
+	      (mm-handle-set-external-undisplayer handle (cons file buffer)))
+	    (message "Displaying %s..." (format method file))
+	    'external)
+	   (copiousoutput
+	    (with-current-buffer outbuf
+	      (forward-line 1)
+	      (mm-insert-inline
+	       handle
+	       (unwind-protect
+		   (progn
+		     (call-process shell-file-name nil
+				   (setq buffer
+					 (generate-new-buffer " *mm*"))
+				   nil
+				   shell-command-switch
+				   (mm-mailcap-command
+				    method file (mm-handle-type handle)))
+		     (if (buffer-live-p buffer)
+			 (save-excursion
+			   (set-buffer buffer)
+			   (buffer-string))))
+		 (progn
+		   (ignore-errors (delete-file file))
+		   (ignore-errors (delete-directory
+				   (file-name-directory file)))
+		   (ignore-errors (kill-buffer buffer))))))
+	    'inline)
+	   (t
+	    (unwind-protect
+		(start-process "*display*"
+			       (setq buffer
+				     (generate-new-buffer " *mm*"))
+			       shell-file-name
+			       shell-command-switch
+			       (mm-mailcap-command
+				method file (mm-handle-type handle)))
+	      (mm-handle-set-external-undisplayer
+	       handle (cons file buffer)))
+	    (message "Displaying %s..." (format method file))
+	    'external)))))))
 
 (defun mm-mailcap-command (method file type-list)
   (let ((ctl (cdr type-list))
@@ -714,16 +788,18 @@ external if displayed external."
 	(push "%" out))
        ((string= total "%s")
 	(setq uses-stdin nil)
-	(push (mm-quote-arg file) out))
+	(push (mm-quote-arg
+	       (gnus-map-function mm-path-name-rewrite-functions file)) out))
        ((string= total "%t")
 	(push (mm-quote-arg (car type-list)) out))
        (t
 	(push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
     (push (substring method beg (length method)) out)
-    (if uses-stdin
-	(progn
-	  (push "<" out)
-	  (push (mm-quote-arg file) out)))
+    (when uses-stdin
+      (push "<" out)
+      (push (mm-quote-arg
+	     (gnus-map-function mm-path-name-rewrite-functions file))
+	    out))
     (mapconcat 'identity (nreverse out) "")))
 
 (defun mm-remove-parts (handles)
@@ -895,20 +971,22 @@ external if displayed external."
       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 	  (with-temp-buffer
 	    (insert-buffer-substring (mm-handle-buffer handle))
-	    (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)))
+	    (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))
-	  (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)))))))
+	  (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))))))))
 
 (defun mm-file-name-delete-whitespace (file-name)
   "Remove all whitespace characters from FILE-NAME."
@@ -950,9 +1028,8 @@ like underscores."
 					(file-name-nondirectory filename))))
     (setq file
 	  (read-file-name "Save MIME part to: "
-			  (expand-file-name
-			   (or filename name "")
-			   (or mm-default-directory default-directory))))
+			  (or mm-default-directory default-directory)
+			  nil nil (or filename name "")))
     (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? "
@@ -1090,30 +1167,33 @@ be determined."
 					(or (mm-image-type-from-buffer)
 					    (intern type))
 					'data-p)
-			(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 (make-temp-name
-				       (expand-file-name "emm.xbm"
-							 mm-tmp-directory))))
-			    (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))))))))
+			(mm-create-image-xemacs type))))
 	    (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.xbm"
+				   mm-tmp-directory))))
+      (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)))
@@ -1218,10 +1298,22 @@ If RECURSIVE, search recursively."
 			 (car handle))))
 
 (defun mm-possibly-verify-or-decrypt (parts ctl)
-  (let ((subtype (cadr (split-string (car ctl) "/")))
+  (let ((type (car ctl))
+	(subtype (cadr (split-string (car ctl) "/")))
 	(mm-security-handle ctl) ;; (car CTL) is the type.
 	protocol func functest)
     (cond
+     ((or (equal type "application/x-pkcs7-mime")
+	  (equal type "application/pkcs7-mime"))
+      (with-temp-buffer
+	(when (and (cond
+		    ((eq mm-decrypt-option 'never) nil)
+		    ((eq mm-decrypt-option 'always) t)
+		    ((eq mm-decrypt-option 'known) t)
+		    (t (y-or-n-p
+			(format "Decrypt (S/MIME) part? "))))
+		   (mm-view-pkcs7 parts))
+	  (setq parts (mm-dissect-buffer t)))))
      ((equal subtype "signed")
       (unless (and (setq protocol
 			 (mm-handle-multipart-ctl-parameter ctl 'protocol))