X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=38d6cfa1d818737ee20291b1fdda8a45330f3c6d;hb=refs%2Fheads%2Fsemi-pgpgpg;hp=66e38f3b7940cf522be2900d622ae7ca693c58d7;hpb=a931e6e2a8c223db9f24fe0e23ad758d3274a488;p=elisp%2Fsemi.git

diff --git a/mime-play.el b/mime-play.el
index 66e38f3..38d6cfa 100644
--- a/mime-play.el
+++ b/mime-play.el
@@ -36,6 +36,13 @@
     (error (defvar bbdb-buffer-name nil)))
   )
 
+(defcustom mime-save-directory "~/"
+  "*Name of the directory where MIME entity will be saved in.
+If t, it means current directory."
+  :group 'mime-view
+  :type '(choice (const :tag "Current directory" t)
+		 (directory)))
+
 (defvar mime-acting-situation-example-list nil)
 
 (defvar mime-acting-situation-example-list-max-size 16)
@@ -64,56 +71,91 @@
 (add-hook 'kill-emacs-hook 'mime-save-acting-situation-examples)
 
 (defun mime-reduce-acting-situation-examples ()
-  (let* ((rest mime-acting-situation-example-list)
-	 (min-example (car rest))
-	 (min-score (cdr min-example)))
-    (while rest
-      (let* ((example (car rest))
-	     (score (cdr example)))
-	(cond ((< score min-score)
-	       (setq min-score score
-		     min-example example)
-	       )
-	      ((= score min-score)
-	       (if (<= (length (car example))(length (car min-example)))
-		   (setq min-example example)
-		 ))
-	      ))
-      (setq rest (cdr rest)))
-    (setq mime-acting-situation-example-list
-	  (delq min-example mime-acting-situation-example-list))
-    (setq min-example (car min-example))
-    (let ((examples mime-acting-situation-example-list)
-	  (max-score 0)
-	  max-examples)
-      (while examples
-	(let* ((ret (mime-compare-situation-with-example min-example
-							 (caar examples)))
-	       (ret-score (car ret)))
-	  (cond ((> ret-score max-score)
-		 (setq max-score ret-score
-		       max-examples (list (cdr ret)))
+  (let ((len (length mime-acting-situation-example-list))
+	i ir ic j jr jc ret
+	dest d-i d-j
+	(max-sim 0) sim
+	min-det-ret det-ret
+	min-det-org det-org
+	min-freq freq)
+    (setq i 0
+	  ir mime-acting-situation-example-list)
+    (while (< i len)
+      (setq ic (car ir)
+	    j 0
+	    jr mime-acting-situation-example-list)
+      (while (< j len)
+	(unless (= i j)
+	  (setq jc (car jr))
+	  (setq ret (mime-compare-situation-with-example (car ic)(car jc))
+		sim (car ret)
+		det-ret (+ (length (car ic))(length (car jc)))
+		det-org (length (cdr ret))
+		freq (+ (cdr ic)(cdr jc)))
+	  (cond ((< max-sim sim)
+		 (setq max-sim sim
+		       min-det-ret det-ret
+		       min-det-org det-org
+		       min-freq freq
+		       d-i i
+		       d-j j
+		       dest (cons (cdr ret) freq))
 		 )
-		((= ret-score max-score)
-		 (setq max-examples (cons (cdr ret) max-examples))
-		 )))
-	(setq examples (cdr examples)))
-      (while max-examples
-	(let* ((example (car max-examples))
-	       (cell (assoc example mime-acting-situation-example-list)))
-	  (if cell
-	      (setcdr cell (1+ (cdr cell)))
-	    (setq mime-acting-situation-example-list
-		  (cons (cons example 0)
-			mime-acting-situation-example-list))
-	    ))
-	(setq max-examples (cdr max-examples))
-	))))
+		((= max-sim sim)
+		 (cond ((> min-det-ret det-ret)
+			(setq min-det-ret det-ret
+			      min-det-org det-org
+			      min-freq freq
+			      d-i i
+			      d-j j
+			      dest (cons (cdr ret) freq))
+			)
+		       ((= min-det-ret det-ret)
+			(cond ((> min-det-org det-org)
+			       (setq min-det-org det-org
+				     min-freq freq
+				     d-i i
+				     d-j j
+				     dest (cons (cdr ret) freq))
+			       )
+			      ((= min-det-org det-org)
+			       (cond ((> min-freq freq)
+				      (setq min-freq freq
+					    d-i i
+					    d-j j
+					    dest (cons (cdr ret) freq))
+				      ))
+			       ))
+			))
+		 ))
+	  )
+	(setq jr (cdr jr)
+	      j (1+ j)))
+      (setq ir (cdr ir)
+	    i (1+ i)))
+    (if (> d-i d-j)
+	(setq i d-i
+	      d-i d-j
+	      d-j i))
+    (setq jr (nthcdr (1- d-j) mime-acting-situation-example-list))
+    (setcdr jr (cddr jr))
+    (if (= d-i 0)
+	(setq mime-acting-situation-example-list
+	      (cdr mime-acting-situation-example-list))
+      (setq ir (nthcdr (1- d-i) mime-acting-situation-example-list))
+      (setcdr ir (cddr ir))
+      )
+    (if (setq ir (assoc (car dest) mime-acting-situation-example-list))
+	(setcdr ir (+ (cdr ir)(cdr dest)))
+      (setq mime-acting-situation-example-list
+	    (cons dest mime-acting-situation-example-list))
+      )))
 
 
 ;;; @ content decoder
 ;;;
 
+;;;###autoload
 (defun mime-preview-play-current-entity (&optional ignore-examples mode)
   "Play current entity.
 It decodes current entity to call internal or external method.  The
@@ -124,7 +166,15 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
   (interactive "P")
   (let ((entity (get-text-property (point) 'mime-view-entity)))
     (if entity
-	(let ((situation (list (cons 'mode (or mode "play")))))
+	(let ((situation
+	       (get-text-property (point) 'mime-view-situation)))
+	  (or mode
+	      (setq mode "play"))
+	  (setq situation 
+		(if (assq 'mode situation)
+		    (put-alist 'mode mode (copy-alist situation))
+		  (cons (cons 'mode mode)
+			situation)))
 	  (if ignore-examples
 	      (setq situation
 		    (cons (cons 'ignore-examples ignore-examples)
@@ -198,12 +248,14 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
     (cons match example)
     ))
 
+;;;###autoload
 (defun mime-play-entity (entity &optional situation ignored-method)
   "Play entity specified by ENTITY.
 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 (method ret)
+    (in-calist-package 'mime-view)
     (setq ret
 	  (mime-delq-null-situation
 	   (ctree-find-calist mime-acting-condition
@@ -289,7 +341,11 @@ specified, play as it.  Default MODE is \"play\"."
           ;;  )
 	  (t
 	   (mime-show-echo-buffer "No method are specified for %s\n"
-				  (mime-entity-type/subtype entity))
+				  (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))
 	   ))
     ))
 
@@ -347,33 +403,45 @@ Otherwise `mime-show-echo-buffer' uses it as height of mime-echo
 window.")
 
 (defun mime-show-echo-buffer (&rest forms)
-  "Show mime-echo buffer to display MIME-playing information."
+  "Show mime-echo buffer to display MIME-playing information.
+It returns the list of window, start and end positions of inserted text.
+A window height of the buffer `mime-echo-buffer-name' will be determined
+by `mime-echo-window-height' (its value or its return value) whenever
+this function is called."
   (get-buffer-create mime-echo-buffer-name)
   (let ((the-win (selected-window))
-	(win (get-buffer-window mime-echo-buffer-name)))
-    (unless win
+	(win (get-buffer-window mime-echo-buffer-name))
+	(height (if (functionp mime-echo-window-height)
+		    (funcall mime-echo-window-height)
+		  mime-echo-window-height))
+	(window-min-height 1)
+	start)
+    (if win
+	(progn
+	  (select-window win)
+	  (enlarge-window (max 0 (- height (window-height))))
+	  )
       (unless (and mime-echo-window-is-shared-with-bbdb
 		   (condition-case nil
-		       (setq win (get-buffer-window bbdb-buffer-name))
+		       (select-window
+			(setq win (get-buffer-window bbdb-buffer-name))
+			)
 		     (error nil)))
 	(select-window (get-buffer-window (or mime-preview-buffer
 					      (current-buffer))))
-	(setq win (split-window-vertically
-		   (- (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)
-      )
-    (select-window win)
-    (goto-char (point-max))
+	(setq win (split-window-vertically (- (window-height) height)))
+	(set-window-buffer win mime-echo-buffer-name)
+	(select-window win)
+	))
+    (goto-char (setq start (point-max)))
     (if forms
-	(insert (apply (function format) forms))
-      )
-    (select-window the-win)
-    ))
+	(let ((buffer-read-only nil))
+	  (insert (apply (function format) forms))
+	  ))
+    (prog1
+	(list win start (point))
+      (select-window the-win)
+      )))
 
 
 ;;; @ file name
@@ -393,8 +461,8 @@ window.")
   (let ((filename
 	 (or (mime-entity-filename entity)
 	     (let ((subj
-		    (or (mime-read-field 'Content-Description entity)
-			(mime-read-field 'Subject entity))))
+		    (or (mime-entity-read-field entity 'Content-Description)
+			(mime-entity-read-field entity 'Subject))))
 	       (if (and subj
 			(or (string-match mime-view-file-name-regexp-1 subj)
 			    (string-match mime-view-file-name-regexp-2 subj)))
@@ -409,26 +477,25 @@ window.")
 ;;;
 
 (defun mime-save-content (entity situation)
-  (let* ((name (mime-entity-safe-filename entity))
-	 (filename (if (and name (not (string-equal name "")))
-		       (expand-file-name name
-					 (save-window-excursion
-					   (call-interactively
-					    (function
-					     (lambda (dir)
-					       (interactive "DDirectory: ")
-					       dir)))))
-		     (save-window-excursion
-		       (call-interactively
-			(function
-			 (lambda (file)
-			   (interactive "FFilename: ")
-			   (expand-file-name file)))))))
-	 )
+  (let ((name (or (mime-entity-safe-filename entity)
+		  (format "%s" (mime-entity-media-type entity))))
+	(dir (if (eq t mime-save-directory)
+		 default-directory
+	       mime-save-directory))
+	filename)
+    (setq filename (read-file-name
+		    (concat "File name: (default "
+			    (file-name-nondirectory name) ") ")
+		    dir
+		    (concat (file-name-as-directory dir)
+			    (file-name-nondirectory name))))
+    (if (file-directory-p filename)
+	(setq filename (concat (file-name-as-directory filename)
+			       (file-name-nondirectory name))))
     (if (file-exists-p filename)
 	(or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
 	    (error "")))
-    (mime-write-entity-content entity filename)
+    (mime-write-entity-content entity (expand-file-name filename))
     ))
 
 
@@ -463,16 +530,14 @@ SUBTYPE is symbol to indicate subtype of media-type.")
 			  )
 		      t)))
 	(setq rest (cdr rest))))
-    (if type
-	(mime-play-entity
-	 entity
-	 (put-alist 'type type
-		    (put-alist 'subtype subtype
-			       (del-alist 'method
-					  (copy-alist situation))))
-	 'mime-detect-content)
-      ))
-  )
+    (setq situation (del-alist 'method (copy-alist situation)))
+    (mime-play-entity entity
+		      (if type
+			  (put-alist 'type type
+				     (put-alist 'subtype subtype
+						situation))
+			situation)
+		      'mime-detect-content)))
 
 
 ;;; @ mail/news message
@@ -481,10 +546,11 @@ 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 ((mother mime-mother-buffer)
-	(win-conf mime-preview-original-window-configuration)
-	)
-    (kill-buffer mime-raw-buffer)
+  (let ((raw-buffer (mime-entity-buffer
+		     (get-text-property (point-min) 'mime-view-entity)))
+	(mother mime-mother-buffer)
+	(win-conf mime-preview-original-window-configuration))
+    (kill-buffer raw-buffer)
     (mime-preview-kill-buffer)
     (set-window-configuration win-conf)
     (pop-to-buffer mother)
@@ -494,22 +560,24 @@ It is registered to variable `mime-preview-quitting-method-alist'."
   (let* ((new-name
 	  (format "%s-%s" (buffer-name) (mime-entity-number entity)))
 	 (mother (current-buffer))
-	 (children (car (mime-entity-children entity))))
-    (set-buffer (get-buffer-create new-name))
-    (erase-buffer)
-    (mime-insert-entity children)
-    (setq mime-message-structure children)
-    (setq major-mode 'mime-show-message-mode)
-    (mime-view-buffer (current-buffer) nil mother
-		      nil (if (mime-entity-cooked-p entity) 'cooked))
-    ))
+	 (children (car (mime-entity-children entity)))
+	 (preview-buffer
+	  (mime-display-message
+	   children new-name mother nil
+	   (cdr (assq 'major-mode
+		      (get-text-property (point) 'mime-view-situation))))))
+    (or (get-buffer-window preview-buffer)
+	(let ((m-win (get-buffer-window mother)))
+	  (if m-win
+	      (set-window-buffer m-win preview-buffer)
+	    (switch-to-buffer preview-buffer)
+	    )))))
 
 
 ;;; @ message/partial
 ;;;
 
 (defun mime-store-message/partial-piece (entity cal)
-  (goto-char (mime-entity-point-min entity))
   (let* ((root-dir
 	  (expand-file-name
 	   (concat "m-prts-" (user-login-name)) temporary-file-directory))
@@ -517,33 +585,28 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 	 (number (cdr (assoc "number" cal)))
 	 (total (cdr (assoc "total" cal)))
 	 file
-	 (mother mime-preview-buffer)
-	 )
+	 (mother (current-buffer)))
     (or (file-exists-p root-dir)
-	(make-directory root-dir)
-	)
+	(make-directory root-dir))
     (setq id (replace-as-filename id))
     (setq root-dir (concat root-dir "/" id))
     (or (file-exists-p root-dir)
-	(make-directory root-dir)
-	)
+	(make-directory root-dir))
     (setq file (concat root-dir "/FULL"))
     (if (file-exists-p file)
 	(let ((full-buf (get-buffer-create "FULL"))
 	      (pwin (or (get-buffer-window mother)
 			(get-largest-window)))
-	      )
+	      pbuf)
 	  (save-window-excursion
 	    (set-buffer full-buf)
 	    (erase-buffer)
 	    (as-binary-input-file (insert-file-contents file))
 	    (setq major-mode 'mime-show-message-mode)
 	    (mime-view-buffer (current-buffer) nil mother)
+	    (setq pbuf (current-buffer))
 	    )
-	  (set-window-buffer pwin
-			     (save-excursion
-			       (set-buffer full-buf)
-			       mime-preview-buffer))
+	  (set-window-buffer pwin pbuf)
 	  (select-window pwin)
 	  )
       (setq file (concat root-dir "/" number))
@@ -575,7 +638,9 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 			 (kill-buffer (current-buffer))
 			 )))
 		)))
-      (if (and total (> total 0))
+      (if (and total (> total 0)
+	       (>= (length (directory-files root-dir nil "^[0-9]+$" t))
+		   total))
 	  (catch 'tag
 	    (save-excursion
 	      (set-buffer (get-buffer-create mime-temp-buffer-name))
@@ -606,15 +671,11 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 		  (and (file-exists-p file)
 		       (delete-file file)
 		       ))
-		(save-window-excursion
-		  (setq major-mode 'mime-show-message-mode)
-		  (mime-view-buffer (current-buffer) nil mother)
-		  )
 		(let ((pwin (or (get-buffer-window mother)
 				(get-largest-window)))
-		      (pbuf (save-excursion
-			      (set-buffer full-buf)
-			      mime-preview-buffer)))
+		      (pbuf (mime-display-message
+			     (mime-open-entity 'buffer (current-buffer))
+			     nil mother nil 'mime-show-message-mode)))
 		  (set-window-buffer pwin pbuf)
 		  (select-window pwin)
 		  )))))
@@ -670,7 +731,12 @@ It is registered to variable `mime-preview-quitting-method-alist'."
       (mule-caesar-region (point-min) (point-max))
       (set-buffer-modified-p nil)
       )
+    (let ((win (get-buffer-window (current-buffer))))
+      (or (eq (selected-window) win)
+	  (select-window (or win (get-largest-window)))
+	  ))
     (view-buffer buf)
+    (goto-char (point-min))
     ))