X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=6e1d206ded5f83fb850d9194ad1122b22d9ad31f;hb=refs%2Fheads%2Fakemi;hp=b1636418f9476eb7dd2f3fa6aa50c9ffc59692da;hpb=aaf782b39b27b98647e23362e17bf120db6b6017;p=elisp%2Fsemi.git

diff --git a/mime-play.el b/mime-play.el
index b163641..6e1d206 100644
--- a/mime-play.el
+++ b/mime-play.el
@@ -1,6 +1,6 @@
 ;;; mime-play.el --- Playback processing module for mime-view.el
 
-;; Copyright (C) 1994,1995,1996,1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1994,1995,1996,1997,1998,1999 Free Software Foundation, Inc.
 
 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
 ;; Created: 1995/9/26 (separated from tm-view.el)
@@ -29,15 +29,17 @@
 (require 'mime-view)
 (require 'alist)
 (require 'filename)
+(require 'ccl)
 
 (eval-when-compile
-  (require 'mime-text)
   (condition-case nil
       (require 'bbdb)
     (error (defvar bbdb-buffer-name nil)))
   )
 
-(defvar mime-acting-situation-examples nil)
+(defvar mime-acting-situation-example-list nil)
+
+(defvar mime-acting-situation-example-list-max-size 16)
 
 (defun mime-save-acting-situation-examples ()
   (let* ((file mime-acting-situation-examples-file)
@@ -49,10 +51,10 @@
           (erase-buffer)
           (insert ";;; " (file-name-nondirectory file) "\n")
           (insert "\n;; This file is generated automatically by "
-                  mime-view-version-string "\n\n")
+                  mime-view-version "\n\n")
 	  (insert ";;; Code:\n\n")
-	  (pp `(setq mime-acting-situation-examples
-		     ',mime-acting-situation-examples)
+	  (pp `(setq mime-acting-situation-example-list
+		     ',mime-acting-situation-example-list)
 	      (current-buffer))
 	  (insert "\n;;; "
                   (file-name-nondirectory file)
@@ -62,29 +64,109 @@
 
 (add-hook 'kill-emacs-hook 'mime-save-acting-situation-examples)
 
-  
+(defun mime-reduce-acting-situation-examples ()
+  (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))
+		 )
+		((= 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
 ;;;
 
-(defvar mime-preview-after-decoded-position nil)
-
-(defun mime-preview-play-current-entity (&optional mode)
+;;;###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
 method is selected from variable `mime-acting-condition'.
+If IGNORE-EXAMPLES (C-u prefix) is specified, this function ignores
+`mime-acting-situation-example-list'.
 If MODE is specified, play as it.  Default MODE is \"play\"."
-  (interactive (list "play"))
+  (interactive "P")
   (let ((entity (get-text-property (point) 'mime-view-entity)))
     (if entity
-	(let ((the-buf (current-buffer))
-	      (raw-buffer (mime-entity-buffer entity)))
-	  (setq mime-preview-after-decoded-position (point))
-	  (set-buffer raw-buffer)
-	  (mime-raw-play-entity entity mode)
-	  (when (eq (current-buffer) raw-buffer)
-	    (set-buffer the-buf)
-	    (goto-char mime-preview-after-decoded-position)
-	    )))))
+	(let ((situation (list (cons 'mode (or mode "play")))))
+	  (if ignore-examples
+	      (setq situation
+		    (cons (cons 'ignore-examples ignore-examples)
+			  situation)))
+	  (mime-play-entity entity situation)
+	  ))))
 
 (defun mime-sort-situation (situation)
   (sort situation
@@ -121,42 +203,100 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
 	      )))
   )
 
-(defsubst mime-delq-null-situation (situations field)
+(defsubst mime-delq-null-situation (situations field
+					       &optional ignored-value)
   (let (dest)
     (while situations
-      (let ((situation (car situations)))
-	(if (assq field situation)
-	    (setq dest (cons situation dest))
-	  ))
+      (let* ((situation (car situations))
+	     (cell (assq field situation)))
+	(if cell
+	    (or (eq (cdr cell) ignored-value)
+		(setq dest (cons situation dest))
+		)))
       (setq situations (cdr situations)))
     dest))
 
-(defun mime-raw-play-entity (entity &optional mode situation)
+(defun mime-compare-situation-with-example (situation example)
+  (let ((example (copy-alist example))
+	(match 0))
+    (while situation
+      (let* ((cell (car situation))
+	     (key (car cell))
+	     (ecell (assoc key example)))
+	(when ecell
+	  (if (equal cell ecell)
+	      (setq match (1+ match))
+	    (setq example (delq ecell example))
+	    ))
+	)
+      (setq situation (cdr situation))
+      )
+    (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)
-    (or situation
-	(setq situation (mime-entity-situation entity)))
-    (if mode
-	(setq situation (cons (cons 'mode mode) situation))
-      )
-    (setq ret
-	  (or (ctree-match-calist mime-acting-situation-examples situation)
-	      (ctree-match-calist-partially mime-acting-situation-examples
-					    situation)
-	      situation))
     (setq ret
-	  (or (mime-delq-null-situation
-	       (ctree-find-calist mime-acting-condition ret
-				  mime-view-find-every-acting-situation)
-	       'method)
-	      (mime-delq-null-situation
-	       (ctree-find-calist mime-acting-condition situation
-				  mime-view-find-every-acting-situation)
-	       'method)
-	      ))
+	  (mime-delq-null-situation
+	   (ctree-find-calist mime-acting-condition
+			      (mime-entity-situation entity situation)
+			      mime-view-find-every-acting-situation)
+	   'method ignored-method))
+    (or (assq 'ignore-examples situation)
+	(if (cdr ret)
+	    (let ((rest ret)
+		  (max-score 0)
+		  (max-escore 0)
+		  max-examples
+		  max-situations)
+	      (while rest
+		(let ((situation (car rest))
+		      (examples mime-acting-situation-example-list))
+		  (while examples
+		    (let* ((ret
+			    (mime-compare-situation-with-example
+			     situation (caar examples)))
+			   (ret-score (car ret)))
+		      (cond ((> ret-score max-score)
+			     (setq max-score ret-score
+				   max-escore (cdar examples)
+				   max-examples (list (cdr ret))
+				   max-situations (list situation))
+			     )
+			    ((= ret-score max-score)
+			     (cond ((> (cdar examples) max-escore)
+				    (setq max-escore (cdar examples)
+					  max-examples (list (cdr ret))
+					  max-situations (list situation))
+				    )
+				   ((= (cdar examples) max-escore)
+				    (setq max-examples
+					  (cons (cdr ret) max-examples))
+				    (or (member situation max-situations)
+					(setq max-situations
+					      (cons situation max-situations)))
+				    )))))
+		    (setq examples (cdr examples))))
+		(setq rest (cdr rest)))
+	      (when max-situations
+		(setq ret max-situations)
+		(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))
+		  )))))
     (cond ((cdr ret)
 	   (setq ret (select-menu-alist
 		      "Methods"
@@ -168,7 +308,7 @@ specified, play as it.  Default MODE is \"play\"."
 				  situation)))
 			      ret)))
 	   (setq ret (mime-sort-situation ret))
-	   (ctree-set-calist-strictly 'mime-acting-situation-examples ret)
+	   (add-to-list 'mime-acting-situation-example-list (cons ret 0))
 	   )
 	  (t
 	   (setq ret (car ret))
@@ -197,34 +337,28 @@ specified, play as it.  Default MODE is \"play\"."
 (defvar mime-mailcap-method-filename-alist nil)
 
 (defun mime-activate-mailcap-method (entity situation)
-  (save-excursion
-    (save-restriction
-      (let ((start (mime-entity-point-min entity))
-	    (end (mime-entity-point-max entity)))
-	(narrow-to-region start end)
-	(goto-char start)
-	(let ((method (cdr (assoc 'method situation)))
-	      (name (mime-entity-safe-filename entity)))
-	  (setq name
-		(if (and name (not (string= name "")))
-		    (expand-file-name name mime-temp-directory)
-		  (make-temp-name
-		   (expand-file-name "EMI" mime-temp-directory))
-		  ))
-          (mime-write-entity-content entity name)
-	  (message "External method is starting...")
-	  (let ((process
-		 (let ((command
-			(mailcap-format-command
-			 method
-			 (cons (cons 'filename name) situation))))
-		   (start-process command mime-echo-buffer-name
-				  shell-file-name shell-command-switch command)
-		   )))
-	    (set-alist 'mime-mailcap-method-filename-alist process name)
-	    (set-process-sentinel process 'mime-mailcap-method-sentinel)
-	    )
-	  )))))
+  (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))
+	    ))
+    (mime-write-entity-content entity name)
+    (message "External method is starting...")
+    (let ((process
+	   (let ((command
+		  (mailcap-format-command
+		   method
+		   (cons (cons 'filename name) situation))))
+	     (start-process command mime-echo-buffer-name
+			    shell-file-name shell-command-switch command)
+	     )))
+      (set-alist 'mime-mailcap-method-filename-alist process name)
+      (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))))
@@ -234,7 +368,8 @@ specified, play as it.  Default MODE is \"play\"."
   (remove-alist 'mime-mailcap-method-filename-alist process)
   (message (format "%s %s" process event)))
 
-(defvar mime-echo-window-is-shared-with-bbdb t
+(defvar mime-echo-window-is-shared-with-bbdb
+  (module-installed-p 'bbdb)
   "*If non-nil, mime-echo window is shared with BBDB window.")
 
 (defvar mime-echo-window-height
@@ -252,23 +387,23 @@ window.")
   "Show mime-echo buffer to display MIME-playing information."
   (get-buffer-create mime-echo-buffer-name)
   (let ((the-win (selected-window))
-	(win (get-buffer-window mime-echo-buffer-name))
+	(win (get-buffer-window mime-echo-buffer-name)))
+    (unless win
+      (unless (and mime-echo-window-is-shared-with-bbdb
+		   (condition-case nil
+		       (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)
+		      )))
 	)
-    (or win
-	(if (and mime-echo-window-is-shared-with-bbdb
-		 (boundp 'bbdb-buffer-name)
-		 (setq win (get-buffer-window bbdb-buffer-name))
-		 )
-	    (set-window-buffer win mime-echo-buffer-name)
-	  (select-window (get-buffer-window mime-preview-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)
-	  ))
+      (set-window-buffer win mime-echo-buffer-name)
+      )
     (select-window win)
     (goto-char (point-max))
     (if forms
@@ -337,54 +472,44 @@ window.")
 ;;; @ file detection
 ;;;
 
-(defvar mime-file-content-type-alist
-  '(("JPEG"		image jpeg)
-    ("GIF"		image gif)
-    ("Standard MIDI"	audio midi)
+(defvar mime-magic-type-alist
+  '(("^\377\330\377[\340\356]..JFIF"	image jpeg)
+    ("^\211PNG"				image png)
+    ("^GIF8[79]"			image gif)
+    ("^II\\*\000"			image tiff)
+    ("^MM\000\\*"			image tiff)
+    ("^MThd"				audio midi)
+    ("^\000\000\001\263"		video mpeg)
     )
-  "*Alist of \"file\" output patterns vs. corresponding media-types.
+  "*Alist of regexp about magic-number vs. corresponding media-types.
 Each element looks like (REGEXP TYPE SUBTYPE).
-REGEXP is pattern for \"file\" command output.
+REGEXP is a regular expression to match against the beginning of the
+content of entity.
 TYPE is symbol to indicate primary type of media-type.
 SUBTYPE is symbol to indicate subtype of media-type.")
 
 (defun mime-detect-content (entity situation)
-  (let ((beg (mime-entity-point-min entity))
-	(end (mime-entity-point-max entity)))
-    (goto-char beg)
-    (let* ((name (save-restriction
-		   (narrow-to-region beg end)
-		   (mime-entity-safe-filename entity)
-		   ))
-	   (encoding (or (cdr (assq 'encoding situation)) "7bit"))
-	   (filename (if (and name (not (string-equal name "")))
-			 (expand-file-name name mime-temp-directory)
-		       (make-temp-name
-			(expand-file-name "EMI" mime-temp-directory)))))
-      (mime-write-decoded-region (mime-entity-body-start entity) end
-				 filename encoding)
-      (let (type subtype)
-	(with-temp-buffer
-	  (call-process "file" nil t nil filename)
-	  (goto-char (point-min))
-	  (if (search-forward (concat filename ": ") nil t)
-	      (let ((rest mime-file-content-type-alist))
-		(while (not (let ((cell (car rest)))
-			      (if cell
-				  (if (looking-at (car cell))
-				      (setq type (nth 1 cell)
-					    subtype (nth 2 cell))
-				    )
-				t)))
-		  (setq rest (cdr rest))))))
-	(if type
-	    (mime-raw-play-entity
-	     entity "play"
-	     (put-alist 'type type
-			(put-alist 'subtype subtype
-				   (mime-entity-situation entity))))
-	  ))
-      )))
+  (let (type subtype)
+    (let ((mdata (mime-entity-content entity))
+	  (rest mime-magic-type-alist))
+      (while (not (let ((cell (car rest)))
+		    (if cell
+			(if (string-match (car cell) mdata)
+			    (setq type (nth 1 cell)
+				  subtype (nth 2 cell))
+			  )
+		      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)
+      ))
+  )
 
 
 ;;; @ mail/news message
@@ -405,13 +530,11 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 (defun mime-view-message/rfc822 (entity situation)
   (let* ((new-name
 	  (format "%s-%s" (buffer-name) (mime-entity-number entity)))
-	 (mother mime-preview-buffer)
+	 (mother (current-buffer))
 	 (children (car (mime-entity-children entity))))
     (set-buffer (get-buffer-create new-name))
     (erase-buffer)
-    (insert-buffer-substring (mime-entity-buffer children)
-			     (mime-entity-point-min children)
-			     (mime-entity-point-max children))
+    (mime-insert-entity children)
     (setq mime-message-structure children)
     (setq major-mode 'mime-show-message-mode)
     (mime-view-buffer (current-buffer) nil mother
@@ -423,15 +546,14 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 ;;;
 
 (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)) mime-temp-directory))
+	   (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 mime-preview-buffer)
+	 (mother (current-buffer))
 	 )
     (or (file-exists-p root-dir)
 	(make-directory root-dir)
@@ -452,7 +574,7 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 	    (erase-buffer)
 	    (as-binary-input-file (insert-file-contents file))
 	    (setq major-mode 'mime-show-message-mode)
-	    (mime-view-mode mother)
+	    (mime-view-buffer (current-buffer) nil mother)
 	    )
 	  (set-window-buffer pwin
 			     (save-excursion
@@ -522,11 +644,10 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 		       ))
 		(save-window-excursion
 		  (setq major-mode 'mime-show-message-mode)
-		  (mime-view-mode mother)
+		  (mime-view-buffer (current-buffer) nil mother)
 		  )
 		(let ((pwin (or (get-buffer-window mother)
-				(get-largest-window)
-				))
+				(get-largest-window)))
 		      (pbuf (save-excursion
 			      (set-buffer full-buf)
 			      mime-preview-buffer)))
@@ -563,7 +684,7 @@ It is registered to variable `mime-preview-quitting-method-alist'."
     (search-forward name)
     ))
 
-(defvar mime-raw-browse-url-function (function mime-browse-url))
+(defvar mime-raw-browse-url-function mime-browse-url-function)
 
 (defun mime-view-message/external-url (entity cal)
   (let ((url (cdr (assoc "url" cal))))
@@ -574,25 +695,50 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 ;;; @ rot13-47
 ;;;
 
+(define-ccl-program translate-string
+  '(4
+    (loop
+     (read-multibyte-character r1 r2)
+     (translate-character r0 r1 r2)
+     (write-multibyte-character r1 r2)
+     (repeat))))
+
 (defun mime-view-caesar (entity situation)
   "Internal method for mime-view to display ROT13-47-48 message."
-  (let* ((new-name (format "%s-%s" (buffer-name)
-			   (mime-entity-number entity)))
-	 (mother mime-preview-buffer))
-    (let ((pwin (or (get-buffer-window mother)
-		    (get-largest-window)))
-	  (buf (get-buffer-create new-name)))
-      (set-window-buffer pwin buf)
-      (set-buffer buf)
-      (select-window pwin)
+  (let ((buf (get-buffer-create
+	      (format "%s-%s" (buffer-name) (mime-entity-number entity)))))
+    (with-current-buffer buf
+      (setq buffer-read-only nil)
+      (erase-buffer)
+      (let ((enable-character-translation nil))
+	(mime-insert-text-content entity))
+      (mule-caesar-region (point-min) (point-max))
+      (let ((str (buffer-string))
+	    (status (make-vector 9 nil))
+	    (table
+	     (catch 'tbl
+	       (let ((i 0) e)
+		 (while (and (< i (length translation-table-vector))
+			     (setq e (aref translation-table-vector i)))
+		   (if (eq (cdr e) standard-translation-table-for-decode)
+		       (throw 'tbl i))
+		   (setq i (1+ i)))
+		 nil))))
+	(when table
+	  (aset status 0 table)
+	  (delete-region (point-min) (point-max))
+	  (insert (ccl-execute-on-string
+		   'translate-string
+		   status
+		   str))))
+      (set-buffer-modified-p nil)
       )
-    (setq buffer-read-only nil)
-    (erase-buffer)
-    (mime-text-insert-decoded-body entity)
-    (mule-caesar-region (point-min) (point-max))
-    (set-buffer-modified-p nil)
-    (set-buffer mother)
-    (view-buffer new-name)
+    (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))
     ))
 
 
@@ -611,8 +757,15 @@ It is registered to variable `mime-preview-quitting-method-alist'."
 	    (insert-file-contents file)
 	    (eval-buffer)
 	    ;; format check
-	    (or (eq (car mime-acting-situation-examples) 'type)
-		(setq mime-acting-situation-examples nil))
+	    (condition-case nil
+		(let ((i 0))
+		  (while (and (> (length mime-acting-situation-example-list)
+				 mime-acting-situation-example-list-max-size)
+			      (< i 16))
+		    (mime-reduce-acting-situation-examples)
+		    (setq i (1+ i))
+		    ))
+	      (error (setq mime-acting-situation-example-list nil)))
 	    )
 	(kill-buffer buffer))))