X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=4a9007a06ecd4d77b4d00de76f54c9233aaabd85;hp=b025f7cc60184c6a928e7d3ad43a551f9d726691;hb=0a63db68d21591915aa899eabbadb2320edbdb65;hpb=e24a04beacd9155b0498c1b04ca2107677e2bd03

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index b025f7cc6..4a9007a06 100644
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -47,6 +47,7 @@
 (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."
@@ -63,6 +64,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)
@@ -458,6 +471,11 @@ If not set, `default-directory' will be used."
 (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
@@ -574,6 +592,46 @@ 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)
@@ -614,12 +672,39 @@ MIME-Version header before proceeding."
 				 description)))))
       (if (or (not ctl)
 	      (not (string-match "/" (car ctl))))
-	  (mm-dissect-singlepart
-	   (list mm-dissect-default-type)
-	   (and cte (intern (downcase (mail-header-strip cte))))
-	   no-strict-mime
-	   (and cd (mail-header-parse-content-disposition cd))
-	   description)
+	  (let ((cdl (and cd (mail-header-parse-content-disposition cd))))
+	    (mm-dissect-singlepart
+	     ;; Guess Content-Type from the file name extention.
+	     ;; Some mailer sends a part without type like this:
+	     ;;  Content-Type: ; name="IMG_3156.JPG"
+	     ;;  Content-Disposition: attachment; filename="IMG_3156.JPG"
+	     (list (or
+		    (let ((tem
+			   (or (mail-content-type-get cdl 'filename)
+			       (and ct
+				    (with-temp-buffer
+				      (insert ct)
+				      (goto-char (point-min))
+				      (and (re-search-forward "\
+;[\t\n ]*name=\\([\"']\\|\\([^\t\n\r ]+\\)\\)" nil t)
+					   (or (match-string 2)
+					       (progn
+						 (goto-char (match-beginning 1))
+						 (condition-case nil
+						     (progn
+						       (forward-sexp 1)
+						       (buffer-substring
+							(1+ (match-beginning 1))
+							(1- (point))))
+						   (error nil))))))))))
+		      (and tem
+			   (setq tem (file-name-extension tem))
+			   (require 'mailcap)
+			   (cdr (assoc (concat "." (downcase tem))
+				       mailcap-mime-extensions))))
+		    mm-dissect-default-type))
+	     (and cte (intern (downcase (mail-header-strip cte))))
+	     no-strict-mime cdl description))
 	(setq type (split-string (car ctl) "/"))
 	(setq subtype (cadr type)
 	      type (car type))
@@ -896,10 +981,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
@@ -913,11 +1008,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
@@ -950,7 +1049,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*"))
@@ -963,35 +1062,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)))))))
 
@@ -1346,7 +1442,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)))
@@ -1809,6 +1905,7 @@ If RECURSIVE, search recursively."
 	 (libxml-parse-html-region (point-min) (point-max))))
       (unless (bobp)
 	(insert "\n"))
+      (mm-convert-shr-links)
       (mm-handle-set-undisplayer
        handle
        `(lambda ()
@@ -1816,6 +1913,25 @@ If RECURSIVE, search recursively."
 	    (delete-region ,(point-min-marker)
 			   ,(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)
+	(setq start end)))))
+
 (defun mm-handle-filename (handle)
   "Return filename of HANDLE if any."
   (or (mail-content-type-get (mm-handle-type handle)