X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=3fdcdba45c0ee47cf1474eaaf4f7590f8852c948;hp=5f5d06d4d8a599db584d7002f56c97f222432771;hb=cae9659706ab3769973b310e7c93f972337e6b8a;hpb=a10e061d0e6d4792608c61659d34a0c770c1129b

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index 5f5d06d4d..3fdcdba45 100644
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,6 +1,6 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
 
-;; Copyright (C) 1998-2012  Free Software Foundation, Inc.
+;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -23,28 +23,30 @@
 
 ;;; Code:
 
-;; For Emacs <22.2 and XEmacs.
-(eval-and-compile
-  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
-
 (require 'mail-parse)
 (require 'mm-bodies)
-(require 'mm-archive)
-(eval-when-compile (require 'cl)
-		   (require 'term))
+(eval-when-compile (require 'cl))
 
 (autoload 'gnus-map-function "gnus-util")
 (autoload 'gnus-replace-in-string "gnus-util")
 (autoload 'gnus-read-shell-command "gnus-util")
 
+(autoload 'gnus-overlays-at "gnus")
+(autoload 'gnus-overlay-put "gnus")
+
 (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 'mm-archive-decoders "mm-archive")
+(autoload 'mm-archive-dissect-and-inline "mm-archive")
+(autoload 'mm-dissect-archive "mm-archive")
+
 (defvar gnus-current-window-configuration)
 
 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
+(add-hook 'gnus-exit-gnus-hook 'mm-temp-files-delete)
 
 (defgroup mime-display ()
   "Display of MIME in mail and news articles."
@@ -61,6 +63,18 @@
   :group 'news
   :group 'multimedia)
 
+(defface mm-command-output
+  '((((class color)
+      (background dark))
+     (:foreground "ForestGreen"))
+    (((class color)
+      (background light))
+     (:foreground "red3"))
+    (t
+     (:italic t)))
+  "Face used for displaying output from commands."
+  :group 'mime-display)
+
 ;;; Convenience macros.
 
 (defmacro mm-handle-buffer (handle)
@@ -109,7 +123,6 @@
 	((executable-find "w3m") 'gnus-w3m)
 	((executable-find "links") 'links)
 	((executable-find "lynx") 'lynx)
-	((locate-library "w3") 'w3)
 	((locate-library "html2text") 'html2text)
 	(t nil))
   "Render of HTML contents.
@@ -121,13 +134,11 @@ The defined renderer types are:
 `w3m-standalone': use plain w3m;
 `links': use links;
 `lynx': use lynx;
-`w3': use Emacs/W3;
 `html2text': use html2text;
 nil    : use external viewer (default web browser)."
   :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)
@@ -138,9 +149,9 @@ nil    : use external viewer (default web browser)."
   :group 'mime-display)
 
 (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
-documentation for the `mm-w3m-safe-url-regexp' variable."
+  "If non-nil, Gnus will allow retrieving images in HTML that has <img> tags.
+See also the documentation for the `mm-w3m-safe-url-regexp'
+variable."
   :version "22.1"
   :type 'boolean
   :group 'mime-display)
@@ -278,7 +289,8 @@ before the external MIME handler is invoked."
 		     (ignore-errors
 		       (if (fboundp 'create-image)
 			   (create-image (buffer-string) 'imagemagick 'data-p)
-			 (mm-create-image-xemacs (mm-handle-media-subtype handle))))))
+			 (mm-create-image-xemacs
+			  (mm-handle-media-subtype handle))))))
 		(when image
 		  (setcar (cdr handle) (list "image/imagemagick"))
 		  (mm-image-fit-p handle)))))))
@@ -454,6 +466,12 @@ If not set, `default-directory' will be used."
 (defvar mm-last-shell-command "")
 (defvar mm-content-id-alist nil)
 (defvar mm-postponed-undisplay-list nil)
+(defvar mm-inhibit-auto-detect-attachment nil)
+(defvar mm-temp-files-to-be-deleted nil
+  "List of temporary files scheduled to be deleted.")
+(defvar mm-temp-files-cache-file (concat ".mm-temp-files-" (user-login-name))
+  "Name of a file that caches a list of temporary files to be deleted.
+The file will be saved in the directory `mm-tmp-directory'.")
 
 ;; According to RFC2046, in particular, in a digest, the default
 ;; Content-Type value for a body part is changed from "text/plain" to
@@ -516,14 +534,6 @@ result of the verification."
     map)
   "Keymap for input viewer with completion.")
 
-(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.")
-
 ;;; The functions.
 
 (defun mm-alist-to-plist (alist)
@@ -570,10 +580,52 @@ Postpone undisplaying of viewers for types in
     (message "Destroying external MIME viewers")
     (mm-destroy-parts mm-postponed-undisplay-list)))
 
+(defun mm-temp-files-delete ()
+  "Delete temporary files and those parent directories.
+Note that the deletion may fail if a program is catching hold of a file
+under Windows or Cygwin.  In that case, it schedules the deletion of
+files left at the next time."
+  (let* ((coding-system-for-read mm-universal-coding-system)
+	 (coding-system-for-write mm-universal-coding-system)
+	 (cache-file (expand-file-name mm-temp-files-cache-file
+				       mm-tmp-directory))
+	 (cache (when (file-exists-p cache-file)
+		  (mm-with-multibyte-buffer
+		    (insert-file-contents cache-file)
+		    (split-string (buffer-string) "\n" t))))
+	 fails)
+    (dolist (temp (append cache mm-temp-files-to-be-deleted))
+      (when (and (file-exists-p temp)
+		 (if (file-directory-p temp)
+		     ;; A parent directory left at the previous time.
+		     (progn
+		       (ignore-errors (delete-directory temp))
+		       (file-exists-p temp))
+		   ;; Delete a temporary file and its parent directory.
+		   (ignore-errors (delete-file temp))
+		   (or (file-exists-p temp)
+		       (progn
+			 (setq temp (file-name-directory temp))
+			 (ignore-errors (delete-directory temp))
+			 (file-exists-p temp)))))
+	(push temp fails)))
+    (if fails
+	;; Schedule the deletion of the files left at the next time.
+	(progn
+	  (write-region (concat (mapconcat 'identity (nreverse fails) "\n")
+				"\n")
+			nil cache-file nil 'silent)
+	  (set-file-modes cache-file #o600))
+      (when (file-exists-p cache-file)
+	(ignore-errors (delete-file cache-file))))
+    (setq mm-temp-files-to-be-deleted nil)))
+
 (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."
+  "Dissect the current buffer and return a list of MIME handles.
+If NO-STRICT-MIME, don't require the message to have a
+MIME-Version header before proceeding."
   (save-excursion
     (let (ct ctl type subtype cte cd description id result)
       (save-restriction
@@ -598,7 +650,7 @@ Postpone undisplaying of viewers for types in
 	  (unless from
 	    (setq from (mail-fetch-field "from")))
 	  ;; FIXME: In some circumstances, this code is running within
-	  ;; an unibyte macro.  mail-extract-address-components
+	  ;; a unibyte macro.  mail-extract-address-components
 	  ;; creates unibyte buffers. This `if', though not a perfect
 	  ;; solution, avoids most of them.
 	  (if from
@@ -608,9 +660,9 @@ Postpone undisplaying of viewers for types in
 				 description)))))
       (if (or (not ctl)
 	      (not (string-match "/" (car ctl))))
-	  (mm-dissect-singlepart
+	    (mm-dissect-singlepart
 	   (list mm-dissect-default-type)
-	   (and cte (intern (downcase (mail-header-strip cte))))
+	     (and cte (intern (downcase (mail-header-strip cte))))
 	   no-strict-mime
 	   (and cd (mail-header-parse-content-disposition cd))
 	   description)
@@ -662,7 +714,8 @@ Postpone undisplaying of viewers for types in
     ;; Guess what the type of application/octet-stream parts should
     ;; really be.
     (let ((filename (cdr (assq 'filename (cdr cdl)))))
-      (when (and (equal (car ctl) "application/octet-stream")
+      (when (and (not mm-inhibit-auto-detect-attachment)
+		 (equal (car ctl) "application/octet-stream")
 		 filename
 		 (string-match "\\.\\([^.]+\\)$" filename))
 	(let ((new-type (mailcap-extension-to-mime (match-string 1 filename))))
@@ -671,7 +724,7 @@ Postpone undisplaying of viewers for types in
     (let ((handle
 	   (mm-make-handle
 	    (mm-copy-to-buffer) ctl cte nil cdl description nil id))
-	  (decoder (assoc (car ctl) mm-archive-decoders)))
+	  (decoder (assoc (car ctl) (mm-archive-decoders))))
       (if (and decoder
 	       ;; Do automatic decoding
 	       (cadr decoder)
@@ -688,7 +741,9 @@ Postpone undisplaying of viewers for types in
 		(goto-char (point-max))
 		(if (re-search-backward close-delimiter nil t)
 		    (match-beginning 0)
-		  (point-max)))))
+		  (point-max))))
+	 (mm-inhibit-auto-detect-attachment
+	  (equal (car ctl) "multipart/encrypted")))
     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
     (while (and (< (point) end) (re-search-forward boundary end t))
       (goto-char (match-beginning 0))
@@ -759,44 +814,51 @@ external if displayed external."
 			   (mail-content-type-get
 			    (mm-handle-type handle) 'name)
 			   "<file>"))
-	     (external mm-enable-external))
-	(if (and (mm-inlinable-p ehandle)
-		 (mm-inlined-p ehandle))
-	    (progn
-	      (forward-line 1)
-	      (mm-display-inline handle)
-	      'inline)
-	  (when (or method
-		    (not no-default))
-	    (if (and (not method)
-		     (equal "text" (car (split-string type "/"))))
-		(progn
-		  (forward-line 1)
-		  (mm-insert-inline handle (mm-get-part handle))
-		  'inline)
-	      (setq external
-                    (and method ;; If nil, we always use "save".
-		       (stringp method) ;; 'mailcap-save-binary-file
+	     (external mm-enable-external)
+	     (decoder (assoc (car (mm-handle-type handle))
+			     (mm-archive-decoders))))
+	(cond
+	 ((and decoder
+	       (executable-find (caddr decoder)))
+	  (mm-archive-dissect-and-inline handle)
+	  'inline)
+	 ((and (mm-inlinable-p ehandle)
+	       (mm-inlined-p ehandle))
+	  (mm-display-inline handle)
+	  'inline)
+	 ((or method
+	      (not no-default))
+	  (if (and (not method)
+		   (equal "text" (car (split-string type "/"))))
+	      (progn
+		(forward-line 1)
+		(mm-insert-inline handle (mm-get-part handle))
+		'inline)
+	    (setq external
+		  (and method	      ;; If nil, we always use "save".
 		       (or (eq mm-enable-external t)
 			   (and (eq mm-enable-external 'ask)
 				(y-or-n-p
 				 (concat
 				  "Display part (" type
-				  ") using external program"
-				  ;; Can non-string method ever happen?
+				  ") "
 				  (if (stringp method)
 				      (concat
-				       " \"" (format method filename) "\"")
-				    "")
-                                    "? "))))))
-	      (if external
-		  (mm-display-external
-		   handle (or method 'mailcap-save-binary-file))
+				       "using external program \""
+				       (format method filename) "\"")
+				    (format
+				     "by calling `%s' on the contents)" method))
+				  "? "))))))
+	    (if external
 		(mm-display-external
-		 handle 'mailcap-save-binary-file)))))))))
+		 handle (or method 'mailcap-save-binary-file))
+	      (mm-display-external
+	       handle 'mailcap-save-binary-file)))))))))
 
 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
 (defvar mailcap-mime-extensions)	; mailcap-mime-info autoloads
+(declare-function term-mode "term" ())
+(declare-function term-char-mode "term" ())
 
 (defun mm-display-external (handle method)
   "Display HANDLE using METHOD."
@@ -826,7 +888,15 @@ external if displayed external."
 				     (mm-handle-media-type handle) t))))
 	      (unwind-protect
 		  (if method
-		      (funcall method)
+		      (progn
+			(when (and (boundp 'gnus-summary-buffer)
+				   (bufferp gnus-summary-buffer)
+				   (buffer-name gnus-summary-buffer))
+			  ;; So that we pop back to the right place, sort of.
+			  (switch-to-buffer gnus-summary-buffer)
+			  (switch-to-buffer mm))
+			(delete-other-windows)
+			(funcall method))
 		    (mm-save-part handle))
 		(when (and (not non-viewer)
 			   method)
@@ -879,10 +949,20 @@ external if displayed external."
 			    method file (mm-handle-type handle))))
 	      (unwind-protect
 		  (if window-system
-		      (start-process "*display*" nil
-				     mm-external-terminal-program
-				     "-e" shell-file-name
-				     shell-command-switch command)
+		      (set-process-sentinel
+		       (start-process "*display*" nil
+				      mm-external-terminal-program
+				      "-e" shell-file-name
+				      shell-command-switch command)
+		       `(lambda (process state)
+			  (if (eq 'exit (process-status process))
+			      (run-at-time
+			       60.0 nil
+			       (lambda ()
+				 (ignore-errors (delete-file ,file))
+				 (ignore-errors (delete-directory
+						 ,(file-name-directory
+						   file))))))))
 		    (require 'term)
 		    (require 'gnus-win)
 		    (set-buffer
@@ -896,11 +976,15 @@ external if displayed external."
 		    (set-process-sentinel
 		     (get-buffer-process buffer)
 		     `(lambda (process state)
-			(if (eq 'exit (process-status process))
-			    (gnus-configure-windows
-			     ',gnus-current-window-configuration))))
+			(when (eq 'exit (process-status process))
+			  (ignore-errors (delete-file ,file))
+			  (ignore-errors
+			    (delete-directory ,(file-name-directory file)))
+			  (gnus-configure-windows
+			   ',gnus-current-window-configuration))))
 		    (gnus-configure-windows 'display-term))
-		(mm-handle-set-external-undisplayer handle (cons file buffer)))
+		(mm-handle-set-external-undisplayer handle (cons file buffer))
+		(add-to-list 'mm-temp-files-to-be-deleted file t))
 	      (message "Displaying %s..." command))
 	    'external)
 	   (copiousoutput
@@ -933,7 +1017,7 @@ external if displayed external."
 	    (let ((command (mm-mailcap-command
 			    method file (mm-handle-type handle))))
 	      (unwind-protect
-		  (progn
+		  (let ((process-connection-type nil))
 		    (start-process "*display*"
 				   (setq buffer
 					 (generate-new-buffer " *mm*"))
@@ -946,35 +1030,32 @@ external if displayed external."
 				   (buffer buffer)
 				   (command command)
 				   (handle handle))
-		       (run-at-time
-			30.0 nil
-			(lambda ()
-			  (ignore-errors
-			    (delete-file file))
-			  (ignore-errors
-			    (delete-directory (file-name-directory file)))))
 		       (lambda (process state)
 			 (when (eq (process-status process) 'exit)
-			   (condition-case nil
-			       (delete-file file)
-			     (error))
-			   (condition-case nil
-			       (delete-directory (file-name-directory file))
-			     (error))
+			   (run-at-time
+			    60.0 nil
+			    (lambda ()
+			      (ignore-errors (delete-file file))
+			      (ignore-errors (delete-directory
+					      (file-name-directory file)))))
 			   (when (buffer-live-p outbuf)
 			     (with-current-buffer outbuf
 			       (let ((buffer-read-only nil)
 				     (point (point)))
 				 (forward-line 2)
-				 (mm-insert-inline
-				  handle (with-current-buffer buffer
-					   (buffer-string)))
+				 (let ((start (point)))
+				   (mm-insert-inline
+				    handle (with-current-buffer buffer
+					     (buffer-string)))
+				   (put-text-property start (point)
+						      'face 'mm-command-output))
 				 (goto-char point))))
 			   (when (buffer-live-p buffer)
 			     (kill-buffer buffer)))
 			 (message "Displaying %s...done" command)))))
 		(mm-handle-set-external-undisplayer
-		 handle (cons file buffer)))
+		 handle (cons file buffer))
+		(add-to-list 'mm-temp-files-to-be-deleted file t))
 	      (message "Displaying %s..." command))
 	    'external)))))))
 
@@ -1282,14 +1363,26 @@ PROMPT overrides the default one used to ask user for a file name."
     (when filename
       (setq filename (gnus-map-function mm-file-name-rewrite-functions
 					(file-name-nondirectory filename))))
-    (setq file
-          (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))))
+    (while
+	(progn
+	  (setq file
+		(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))))
+	  (cond ((or (not file) (equal file ""))
+		 (message "Please enter a file name")
+		 t)
+		((and (file-directory-p file)
+		      (not filename))
+		 (message "Please enter a non-directory file name")
+		 t)
+		(t nil)))
+      (sit-for 2)
+      (discard-input))
     (if (file-directory-p file)
 	(setq file (expand-file-name filename file))
       (setq file (expand-file-name
@@ -1317,7 +1410,7 @@ Return t if meta tag is added or replaced."
 	(goto-char (point-min))
 	(if (re-search-forward "\
 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
-text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
+text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\([^\"'>]+\\)\\)?[^>]*>" nil t)
 	    (if (and (not force-charset)
 		     (match-beginning 2)
 		     (string-match "\\`html\\'" (match-string 1)))
@@ -1508,7 +1601,7 @@ be determined."
   (let ((image (mm-get-image handle)))
     (or (not image)
 	(if (featurep 'xemacs)
-	    ;; XEmacs' glyphs can actually tell us about their width, so
+	    ;; XEmacs's glyphs can actually tell us about their width, so
 	    ;; let's be nice and smart about them.
 	    (or mm-inline-large-images
 		(and (<= (glyph-width image) (window-pixel-width))
@@ -1725,6 +1818,7 @@ If RECURSIVE, search recursively."
 		  (start end &optional base-url))
 (declare-function shr-insert-document "shr" (dom))
 (defvar shr-blocked-images)
+(defvar shr-use-fonts)
 (defvar gnus-inhibit-images)
 (autoload 'gnus-blocked-images "gnus-art")
 
@@ -1732,6 +1826,10 @@ If RECURSIVE, search recursively."
   ;; Require since we bind its variables.
   (require 'shr)
   (let ((article-buffer (current-buffer))
+	(shr-width (if (and (boundp 'shr-use-fonts)
+			    shr-use-fonts)
+		       nil
+		     fill-column))
 	(shr-content-function (lambda (id)
 				(let ((handle (mm-get-content-id id)))
 				  (when handle
@@ -1756,7 +1854,8 @@ If RECURSIVE, search recursively."
 	 (insert (prog1
 		     (if (and charset
 			      (setq charset
-				    (mm-charset-to-coding-system charset))
+				    (mm-charset-to-coding-system charset
+								 nil t))
 			      (not (eq charset 'ascii)))
 			 (mm-decode-coding-string (buffer-string) charset)
 		       (mm-string-as-multibyte (buffer-string)))
@@ -1772,16 +1871,42 @@ If RECURSIVE, search recursively."
 				    (string-to-number (match-string 2)))
 				  mm-extra-numeric-entities)))
 	     (replace-match (char-to-string char))))
+	 ;; Remove "soft hyphens".
+	 (goto-char (point-min))
+	 (while (search-forward "­" nil t)
+	   (replace-match "" t t))
 	 (libxml-parse-html-region (point-min) (point-max))))
       (unless (bobp)
 	(insert "\n"))
+      (mm-convert-shr-links)
       (mm-handle-set-undisplayer
        handle
        `(lambda ()
 	  (let ((inhibit-read-only t))
-	    (delete-region ,(point-min-marker)
+	    (delete-region ,(copy-marker (point-min) t)
 			   ,(point-max-marker))))))))
 
+(defvar shr-map)
+
+(autoload 'widget-convert-button "wid-edit")
+
+(defun mm-convert-shr-links ()
+  (let ((start (point-min))
+	end)
+    (while (and start
+		(< start (point-max)))
+      (when (setq start (text-property-not-all start (point-max) 'shr-url nil))
+	(setq end (next-single-property-change start 'shr-url nil (point-max)))
+	(widget-convert-button
+	 'url-link start end
+	 :help-echo (get-text-property start 'help-echo)
+	 :keymap shr-map
+	 (get-text-property start 'shr-url))
+	(put-text-property start end 'local-map nil)
+	(dolist (overlay (gnus-overlays-at start))
+	  (gnus-overlay-put overlay 'face nil))
+	(setq start end)))))
+
 (defun mm-handle-filename (handle)
   "Return filename of HANDLE if any."
   (or (mail-content-type-get (mm-handle-type handle)
@@ -1791,4 +1916,8 @@ If RECURSIVE, search recursively."
 
 (provide 'mm-decode)
 
+;; Local Variables:
+;; coding: utf-8
+;; End:
+
 ;;; mm-decode.el ends here