X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=f15f8165c8033be9855a50a83656265aad8a695c;hb=ed6d70aaa4d35c0f0c50df469b886d03931d6fbd;hp=e3774de3e0e18796138da8d541a28a3047b93c91;hpb=c667066a706e9f68b2aae85882b70a8c9f726ebb;p=elisp%2Fsemi.git

diff --git a/mime-play.el b/mime-play.el
index e3774de..f15f816 100644
--- a/mime-play.el
+++ b/mime-play.el
@@ -21,8 +21,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Code:
 
@@ -33,8 +33,7 @@
 (eval-when-compile
   (condition-case nil
       (require 'bbdb)
-    (error (defvar bbdb-buffer-name nil)))
-  )
+    (error (defvar bbdb-buffer-name nil))))
 
 (defcustom mime-save-directory "~/"
   "*Name of the directory where MIME entity will be saved in.
@@ -43,9 +42,17 @@ If t, it means current directory."
   :type '(choice (const :tag "Current directory" t)
 		 (directory)))
 
+(defcustom mime-play-delete-file-immediately t
+  "If non-nil, delete played file immediately."
+  :group 'mime-view
+  :type 'boolean)
+
 (defvar mime-play-find-every-situations t
   "*Find every available situations if non-nil.")
 
+(defvar mime-play-messages-coding-system nil
+  "Coding system to be used for external MIME playback method.")
+
 
 ;;; @ content decoder
 ;;;
@@ -74,8 +81,7 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
 	      (setq situation
 		    (cons (cons 'ignore-examples ignore-examples)
 			  situation)))
-	  (mime-play-entity entity situation)
-	  ))))
+	  (mime-play-entity entity situation)))))
 
 ;;;###autoload
 (defun mime-play-entity (entity &optional situation ignored-method)
@@ -83,51 +89,46 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
 It decodes the entity to call internal or external method.  The method
 is selected from variable `mime-acting-condition'.  If MODE is
 specified, play as it.  Default MODE is \"play\"."
-  (let ((ret
-	 (mime-unify-situations (mime-entity-situation entity situation)
-				mime-acting-condition
-				mime-acting-situation-example-list
-				'method ignored-method
-				mime-play-find-every-situations))
-	method)
+  (let* ((entity-situation (mime-entity-situation entity situation))
+	 (ret (mime-unify-situations entity-situation
+				     mime-acting-condition
+				     mime-acting-situation-example-list
+				     'method ignored-method
+				     mime-play-find-every-situations))
+	 method menu s)
     (setq mime-acting-situation-example-list (cdr ret)
 	  ret (car ret))
     (cond ((cdr ret)
-	   (setq ret (select-menu-alist
-		      "Methods"
-		      (mapcar (function
-			       (lambda (situation)
-				 (cons
-				  (format "%s"
-					  (cdr (assq 'method situation)))
-				  situation)))
-			      ret)))
-	   (setq ret (mime-sort-situation ret))
-	   (add-to-list 'mime-acting-situation-example-list (cons ret 0))
-	   )
+	   (while ret
+	     (or (vassoc (setq method
+			       (format "%s"
+				       (cdr (assq 'method
+						  (setq s (pop ret))))))
+			 menu)
+		 (push (vector method s t) menu)))
+	   (setq ret (mime-sort-situation
+		      (mime-menu-select "Play entity with: "
+					(cons "Methods" menu))))
+	   (add-to-list 'mime-acting-situation-example-list (cons ret 0)))
 	  (t
-	   (setq ret (car ret))
-	   ))
+	   (setq ret (car ret))))
     (setq method (cdr (assq 'method ret)))
     (cond ((and (symbolp method)
 		(fboundp method))
-	   (funcall method entity ret)
-	   )
+	   (funcall method entity ret))
 	  ((stringp method)
-	   (mime-activate-mailcap-method entity ret)
-	   )
+	   (mime-activate-mailcap-method entity ret))
           ;; ((and (listp method)(stringp (car method)))
           ;;  (mime-activate-external-method entity ret)
           ;;  )
 	  (t
-	   (mime-show-echo-buffer "No method are specified for %s\n"
+	   (mime-show-echo-buffer "No method is specified for %s\n"
 				  (mime-type/subtype-string
-				   (cdr (assq 'type situation))
-				   (cdr (assq 'subtype situation))))
-	   (if (y-or-n-p "Do you want to save current entity to disk?")
-	       (mime-save-content entity situation))
-	   ))
-    ))
+				   (cdr (assq 'type entity-situation))
+				   (cdr (assq 'subtype entity-situation))))
+	   (when (y-or-n-p "Do you want to save current entity to disk?")
+	     (message "")
+	     (mime-save-content entity entity-situation))))))
 
 
 ;;; @ external decoder
@@ -138,34 +139,41 @@ specified, play as it.  Default MODE is \"play\"."
 (defun mime-activate-mailcap-method (entity situation)
   (let ((method (cdr (assoc 'method situation)))
 	(name (mime-entity-safe-filename entity)))
-    (setq name
-	  (if (and name (not (string= name "")))
-	      (expand-file-name name temporary-file-directory)
-	    (make-temp-name
-	     (expand-file-name "EMI" temporary-file-directory))
-	    ))
+    (setq name (expand-file-name (if (and name (not (string= name "")))
+				     name
+				   (make-temp-name "EMI"))
+				 (make-temp-file "EMI" 'directory)))
     (mime-write-entity-content entity name)
     (message "External method is starting...")
     (let ((process
 	   (let ((command
-		  (mailcap-format-command
+		  (mime-format-mailcap-command
 		   method
-		   (cons (cons 'filename name) situation))))
+		   (cons (cons 'filename name) situation)))
+		 (coding-system-for-read mime-play-messages-coding-system))
 	     (start-process command mime-echo-buffer-name
-			    shell-file-name shell-command-switch command)
-	     )))
+			    shell-file-name shell-command-switch command))))
       (set-alist 'mime-mailcap-method-filename-alist process name)
-      (set-process-sentinel process 'mime-mailcap-method-sentinel)
-      )
-    ))
+      (set-process-sentinel process 'mime-mailcap-method-sentinel))))
 
 (defun mime-mailcap-method-sentinel (process event)
-  (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
-    (if (file-exists-p file)
-	(delete-file file)
-      ))
-  (remove-alist 'mime-mailcap-method-filename-alist process)
-  (message (format "%s %s" process event)))
+  (when mime-play-delete-file-immediately
+    (let ((file (cdr (assq process mime-mailcap-method-filename-alist))))
+      (when (file-exists-p file)
+	(ignore-errors
+	 (delete-file file)
+	 (delete-directory (file-name-directory file)))))
+    (remove-alist 'mime-mailcap-method-filename-alist process))
+  (message "%s %s" process event))
+
+(defun mime-mailcap-delete-played-files ()
+  (dolist (elem mime-mailcap-method-filename-alist)
+    (when (file-exists-p (cdr elem))
+      (ignore-errors
+	(delete-file (cdr elem))
+	(delete-directory (file-name-directory (cdr elem)))))))
+
+(add-hook 'kill-emacs-hook 'mime-mailcap-delete-played-files)
 
 (defvar mime-echo-window-is-shared-with-bbdb
   (module-installed-p 'bbdb)
@@ -174,8 +182,7 @@ specified, play as it.  Default MODE is \"play\"."
 (defvar mime-echo-window-height
   (function
    (lambda ()
-     (/ (window-height) 5)
-     ))
+     (/ (window-height) 5)))
   "*Size of mime-echo window.
 It allows function or integer.  If it is function,
 `mime-show-echo-buffer' calls it to get height of mime-echo window.
@@ -198,19 +205,14 @@ window.")
 		   (- (window-height)
 		      (if (functionp mime-echo-window-height)
 			  (funcall mime-echo-window-height)
-			mime-echo-window-height)
-		      )))
-	)
-      (set-window-buffer win mime-echo-buffer-name)
-      )
+			mime-echo-window-height)))))
+      (set-window-buffer win mime-echo-buffer-name))
     (select-window win)
     (goto-char (point-max))
     (if forms
 	(let ((buffer-read-only nil))
-	  (insert (apply (function format) forms))
-	  ))
-    (select-window the-win)
-    ))
+	  (insert (apply (function format) forms))))
+    (select-window the-win)))
 
 
 ;;; @ file name
@@ -235,11 +237,9 @@ window.")
 	       (if (and subj
 			(or (string-match mime-view-file-name-regexp-1 subj)
 			    (string-match mime-view-file-name-regexp-2 subj)))
-		   (substring subj (match-beginning 0)(match-end 0))
-		 )))))
+		   (substring subj (match-beginning 0)(match-end 0)))))))
     (if filename
-	(replace-as-filename filename)
-      )))
+	(replace-as-filename filename))))
 
 
 ;;; @ file extraction
@@ -264,8 +264,7 @@ window.")
     (if (file-exists-p filename)
 	(or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 	    (error "")))
-    (mime-write-entity-content entity (expand-file-name filename))
-    ))
+    (mime-write-entity-content entity (expand-file-name filename))))
 
 
 ;;; @ file detection
@@ -278,8 +277,7 @@ window.")
     ("^II\\*\000"			image tiff)
     ("^MM\000\\*"			image tiff)
     ("^MThd"				audio midi)
-    ("^\000\000\001\263"		video mpeg)
-    )
+    ("^\000\000\001\263"		video mpeg))
   "*Alist of regexp about magic-number vs. corresponding media-types.
 Each element looks like (REGEXP TYPE SUBTYPE).
 REGEXP is a regular expression to match against the beginning of the
@@ -295,8 +293,7 @@ SUBTYPE is symbol to indicate subtype of media-type.")
 		    (if cell
 			(if (string-match (car cell) mdata)
 			    (setq type (nth 1 cell)
-				  subtype (nth 2 cell))
-			  )
+				  subtype (nth 2 cell)))
 		      t)))
 	(setq rest (cdr rest))))
     (setq situation (del-alist 'method (copy-alist situation)))
@@ -315,15 +312,13 @@ SUBTYPE is symbol to indicate subtype of media-type.")
 (defun mime-preview-quitting-method-for-mime-show-message-mode ()
   "Quitting method for mime-view.
 It is registered to variable `mime-preview-quitting-method-alist'."
-  (let ((raw-buffer (mime-entity-buffer
-		     (get-text-property (point-min) 'mime-view-entity)))
-	(mother mime-mother-buffer)
+  (let ((mother mime-mother-buffer)
 	(win-conf mime-preview-original-window-configuration))
-    (kill-buffer raw-buffer)
+    (if (buffer-live-p mime-view-temp-message-buffer)
+	(kill-buffer mime-view-temp-message-buffer))
     (mime-preview-kill-buffer)
     (set-window-configuration win-conf)
-    (pop-to-buffer mother)
-    ))
+    (pop-to-buffer mother)))
 
 (defun mime-view-message/rfc822 (entity situation)
   (let* ((new-name
@@ -339,28 +334,59 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 	(let ((m-win (get-buffer-window mother)))
 	  (if m-win
 	      (set-window-buffer m-win preview-buffer)
-	    (switch-to-buffer preview-buffer)
-	    )))))
+	    (switch-to-buffer preview-buffer))))))
 
 
 ;;; @ message/partial
 ;;;
 
+(defun mime-require-safe-directory (dir)
+  "Create a directory DIR safely.
+The permission of the created directory becomes `700' (for the owner only).
+If the directory already exists and is writable by other users, an error
+occurs."
+  (let ((attr (file-attributes dir))
+	(orig-modes (default-file-modes)))
+    (if (and attr (eq (car attr) t)) ; directory already exists.
+	(unless (or (memq system-type '(windows-nt ms-dos OS/2 emx))
+		    (and (eq (nth 2 attr) (user-real-uid))
+			 (eq (file-modes dir) 448)))
+	  (error "Invalid owner or permission for %s" dir))
+      (unwind-protect
+	  (progn
+	    (set-default-file-modes 448)
+	    (make-directory dir))
+	(set-default-file-modes orig-modes)))))
+
+(defvar mime-view-temp-message-buffer nil) ; buffer local variable
+
 (defun mime-store-message/partial-piece (entity cal)
-  (let* ((root-dir
-	  (expand-file-name
-	   (concat "m-prts-" (user-login-name)) temporary-file-directory))
-	 (id (cdr (assoc "id" cal)))
-	 (number (cdr (assoc "number" cal)))
-	 (total (cdr (assoc "total" cal)))
-	 file
-	 (mother (current-buffer)))
+  (let ((root-dir
+	 (expand-file-name
+	  (concat "m-prts-" (user-login-name)) temporary-file-directory))
+	(id (cdr (assoc "id" cal)))
+	(number (cdr (assoc "number" cal)))
+	(total (cdr (assoc "total" cal)))
+	file
+	(mother (current-buffer))
+	(orig-modes (default-file-modes)))
+    (mime-require-safe-directory root-dir)
     (or (file-exists-p root-dir)
-	(make-directory root-dir))
+	(unwind-protect
+	    (progn
+	      (set-default-file-modes 448)
+	      (make-directory root-dir))
+	  (set-default-file-modes orig-modes)))
     (setq id (replace-as-filename id))
     (setq root-dir (concat root-dir "/" id))
+
     (or (file-exists-p root-dir)
-	(make-directory root-dir))
+	(unwind-protect
+	    (progn
+	      (set-default-file-modes 448)
+	      (make-directory root-dir))
+	  (set-default-file-modes orig-modes)))
+
     (setq file (concat root-dir "/FULL"))
     (if (file-exists-p file)
 	(let ((full-buf (get-buffer-create "FULL"))
@@ -370,14 +396,14 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 	  (save-window-excursion
 	    (set-buffer full-buf)
 	    (erase-buffer)
-	    (as-binary-input-file (insert-file-contents file))
+	    (binary-insert-encoded-file file)
 	    (setq major-mode 'mime-show-message-mode)
 	    (mime-view-buffer (current-buffer) nil mother)
 	    (setq pbuf (current-buffer))
-	    )
+	    (make-local-variable 'mime-view-temp-message-buffer)
+	    (setq mime-view-temp-message-buffer full-buf))
 	  (set-window-buffer pwin pbuf)
-	  (select-window pwin)
-	  )
+	  (select-window pwin))
       (setq file (concat root-dir "/" number))
       (mime-write-entity-body entity file)
       (let ((total-file (concat root-dir "/CT")))
@@ -391,10 +417,8 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 			  (erase-buffer)
 			  (insert total)
 			  (write-region (point-min)(point-max) total-file)
-			  (kill-buffer (current-buffer))
-			  ))
-		    (string-to-number total)
-		    )
+			  (kill-buffer (current-buffer))))
+		    (string-to-number total))
 		(and (file-exists-p total-file)
 		     (save-excursion
 		       (set-buffer (find-file-noselect total-file))
@@ -402,11 +426,8 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 			   (and (re-search-forward "[0-9]+" nil t)
 				(string-to-number
 				 (buffer-substring (match-beginning 0)
-						   (match-end 0)))
-				)
-			 (kill-buffer (current-buffer))
-			 )))
-		)))
+						   (match-end 0))))
+			 (kill-buffer (current-buffer))))))))
       (if (and total (> total 0)
 	       (>= (length (directory-files root-dir nil "^[0-9]+$" t))
 		   total))
@@ -419,36 +440,33 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 		  (while (<= i total)
 		    (setq file (concat root-dir "/" (int-to-string i)))
 		    (or (file-exists-p file)
-			(throw 'tag nil)
-			)
-		    (as-binary-input-file (insert-file-contents file))
+			(throw 'tag nil))
+		    (binary-insert-encoded-file file)
 		    (goto-char (point-max))
-		    (setq i (1+ i))
-		    ))
-		(as-binary-output-file
-		 (write-region (point-min)(point-max)
-			       (expand-file-name "FULL" root-dir)))
+		    (setq i (1+ i))))
+		(binary-write-decoded-region
+		 (point-min)(point-max)
+		 (expand-file-name "FULL" root-dir))
 		(let ((i 1))
 		  (while (<= i total)
 		    (let ((file (format "%s/%d" root-dir i)))
 		      (and (file-exists-p file)
-			   (delete-file file)
-			   ))
-		    (setq i (1+ i))
-		    ))
+			   (delete-file file)))
+		    (setq i (1+ i))))
 		(let ((file (expand-file-name "CT" root-dir)))
 		  (and (file-exists-p file)
-		       (delete-file file)
-		       ))
-		(let ((pwin (or (get-buffer-window mother)
+		       (delete-file file)))
+		(let ((buf (current-buffer))
+		      (pwin (or (get-buffer-window mother)
 				(get-largest-window)))
 		      (pbuf (mime-display-message
 			     (mime-open-entity 'buffer (current-buffer))
 			     nil mother nil 'mime-show-message-mode)))
+		  (with-current-buffer pbuf
+		    (make-local-variable 'mime-view-temp-message-buffer)
+		    (setq mime-view-temp-message-buffer buf))
 		  (set-window-buffer pwin pbuf)
-		  (select-window pwin)
-		  )))))
-      )))
+		  (select-window pwin)))))))))
 
 
 ;;; @ message/external-body
@@ -457,32 +475,29 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 (defvar mime-raw-dired-function
   (if (and (>= emacs-major-version 19) window-system)
       (function dired-other-frame)
-    (function mime-raw-dired-function-for-one-frame)
-    ))
+    (function mime-raw-dired-function-for-one-frame)))
 
 (defun mime-raw-dired-function-for-one-frame (dir)
   (let ((win (or (get-buffer-window mime-preview-buffer)
 		 (get-largest-window))))
     (select-window win)
-    (dired dir)
-    ))
+    (dired dir)))
 
 (defun mime-view-message/external-anon-ftp (entity cal)
   (let* ((site (cdr (assoc "site" cal)))
 	 (directory (cdr (assoc "directory" cal)))
 	 (name (cdr (assoc "name" cal)))
 	 (pathname (concat "/anonymous@" site ":" directory)))
-    (message (concat "Accessing " (expand-file-name name pathname) " ..."))
+    (message "%s" (concat "Accessing " (expand-file-name name pathname) "..."))
     (funcall mime-raw-dired-function pathname)
     (goto-char (point-min))
-    (search-forward name)
-    ))
+    (search-forward name)))
 
 (defvar mime-raw-browse-url-function mime-browse-url-function)
 
 (defun mime-view-message/external-url (entity cal)
   (let ((url (cdr (assoc "url" cal))))
-    (message (concat "Accessing " url " ..."))
+    (message "%s" (concat "Accessing " url "..."))
     (funcall mime-raw-browse-url-function url)))
 
 
@@ -498,15 +513,12 @@ It is registered to variable `mime-preview-quitting-method-alist'."
       (erase-buffer)
       (mime-insert-text-content entity)
       (mule-caesar-region (point-min) (point-max))
-      (set-buffer-modified-p nil)
-      )
+      (set-buffer-modified-p nil))
     (let ((win (get-buffer-window (current-buffer))))
       (or (eq (selected-window) win)
-	  (select-window (or win (get-largest-window)))
-	  ))
+	  (select-window (or win (get-largest-window)))))
     (view-buffer buf)
-    (goto-char (point-min))
-    ))
+    (goto-char (point-min))))
 
 
 ;;; @ end