update.

[elisp/semi.git] / mime-play.el

diff --git a/mime-play.el b/mime-play.el
index 497a802..b163641 100644 (file)
--- a/mime-play.el
+++ b/mime-play.el
@@ -34,8 +34,8 @@
   (require 'mime-text)
   (condition-case nil
       (require 'bbdb)
   (require 'mime-text)
   (condition-case nil
       (require 'bbdb)

-    (error (defvar bbdb-buffer-name nil))
-    ))
+    (error (defvar bbdb-buffer-name nil)))
+  )

 
 (defvar mime-acting-situation-examples nil)
 
 
 (defvar mime-acting-situation-examples nil)
 

@@ -73,9 +73,7 @@
 It decodes current 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\"."
 It decodes current 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\"."

-  (interactive)
-  (or mode
-      (setq mode "play"))
+  (interactive (list "play"))

   (let ((entity (get-text-property (point) 'mime-view-entity)))
     (if entity
        (let ((the-buf (current-buffer))
   (let ((entity (get-text-property (point) 'mime-view-entity)))
     (if entity
        (let ((the-buf (current-buffer))

@@ -96,23 +94,26 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
                  (order '((type . 1)
                           (subtype . 2)
                           (mode . 3)
                  (order '((type . 1)
                           (subtype . 2)
                           (mode . 3)

-                          (major-mode . 4)))
+                          (method . 4)
+                          (major-mode . 5)
+                          (disposition-type . 6)
+                          ))

                  a-order b-order)
              (if (symbolp a-t)
                  (let ((ret (assq a-t order)))
                    (if ret
                        (setq a-order (cdr ret))
                  a-order b-order)
              (if (symbolp a-t)
                  (let ((ret (assq a-t order)))
                    (if ret
                        (setq a-order (cdr ret))

-                     (setq a-order 5)
+                     (setq a-order 7)

                      ))
                      ))

-               (setq a-order 6)
+               (setq a-order 8)

                )
              (if (symbolp b-t)
                  (let ((ret (assq b-t order)))
                    (if ret
                        (setq b-order (cdr ret))
                )
              (if (symbolp b-t)
                  (let ((ret (assq b-t order)))
                    (if ret
                        (setq b-order (cdr ret))

-                     (setq b-order 5)
+                     (setq b-order 7)

                      ))
                      ))

-               (setq b-order 6)
+               (setq b-order 8)

                )
              (if (= a-order b-order)
                  (string< (format "%s" a-t)(format "%s" b-t))
                )
              (if (= a-order b-order)
                  (string< (format "%s" a-t)(format "%s" b-t))

@@ -130,28 +131,29 @@ If MODE is specified, play as it.  Default MODE is \"play\"."
       (setq situations (cdr situations)))
     dest))
 
       (setq situations (cdr situations)))
     dest))
 

-(defun mime-raw-play-entity (entity &optional mode)
+(defun mime-raw-play-entity (entity &optional mode situation)

   "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\"."
   "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 cal ret)
-    (setq cal (mime-entity-situation entity))
+  (let (method ret)
+    (or situation
+       (setq situation (mime-entity-situation entity)))

     (if mode
     (if mode

-       (setq cal (cons (cons 'mode mode) cal))
+       (setq situation (cons (cons 'mode mode) situation))

       )
     (setq ret
       )
     (setq ret

-         (or (ctree-match-calist mime-acting-situation-examples cal)
+         (or (ctree-match-calist mime-acting-situation-examples situation)

              (ctree-match-calist-partially mime-acting-situation-examples
              (ctree-match-calist-partially mime-acting-situation-examples

-                                           cal)
-             cal))
+                                           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
     (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 cal
+              (ctree-find-calist mime-acting-condition situation

                                  mime-view-find-every-acting-situation)
               'method)
              ))
                                  mime-view-find-every-acting-situation)
               'method)
              ))

@@ -179,9 +181,9 @@ specified, play as it.  Default MODE is \"play\"."
          ((stringp method)
           (mime-activate-mailcap-method entity ret)
           )
          ((stringp method)
           (mime-activate-mailcap-method entity ret)
           )

-         ((and (listp method)(stringp (car method)))
-          (mime-activate-external-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-entity-type/subtype entity))
          (t
           (mime-show-echo-buffer "No method are specified for %s\n"
                                  (mime-entity-type/subtype entity))

@@ -202,10 +204,14 @@ specified, play as it.  Default MODE is \"play\"."
        (narrow-to-region start end)
        (goto-char start)
        (let ((method (cdr (assoc 'method situation)))
        (narrow-to-region start end)
        (goto-char start)
        (let ((method (cdr (assoc 'method situation)))

-             (name (expand-file-name (mime-raw-get-filename situation)
-                                     mime-temp-directory)))
-         (mime-write-decoded-region (mime-entity-body-start entity) end
-                                    name (cdr (assq 'encoding 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
          (message "External method is starting...")
          (let ((process
                 (let ((command

@@ -228,62 +234,6 @@ specified, play as it.  Default MODE is \"play\"."
   (remove-alist 'mime-mailcap-method-filename-alist process)
   (message (format "%s %s" process event)))
 
   (remove-alist 'mime-mailcap-method-filename-alist process)
   (message (format "%s %s" process event)))
 

-(defun mime-activate-external-method (entity cal)
-  (save-excursion
-    (save-restriction
-      (let ((beg (mime-entity-point-min entity))
-           (end (mime-entity-point-max entity)))
-       (narrow-to-region beg end)
-       (goto-char beg)
-       (let ((method (cdr (assoc 'method cal)))
-             (name (mime-raw-get-filename cal)))
-         (if method
-             (let ((file (make-temp-name
-                          (expand-file-name "TM" mime-temp-directory)))
-                   b args)
-               (if (nth 1 method)
-                   (setq b beg)
-                 (setq b
-                       (if (re-search-forward "^$" nil t)
-                           (1+ (match-end 0))
-                         (point-min)
-                         ))
-                 )
-               (goto-char b)
-               (write-region b end file)
-               (message "External method is starting...")
-               (setq cal (put-alist
-                          'name (replace-as-filename name) cal))
-               (setq cal (put-alist 'file file cal))
-               (setq args (nconc
-                           (list (car method)
-                                 mime-echo-buffer-name (car method)
-                                 )
-                           (mime-make-external-method-args
-                            cal (cdr (cdr method)))
-                           ))
-               (apply (function start-process) args)
-               (mime-show-echo-buffer)
-               ))
-         )))))
-
-(defun mime-make-external-method-args (cal format)
-  (mapcar (function
-          (lambda (arg)
-            (if (stringp arg)
-                arg
-              (let* ((item (eval arg))
-                     (ret (cdr (assoc item cal)))
-                     )
-                (if ret
-                    ret
-                  (if (eq item 'encoding)
-                      "7bit"
-                    ""))
-                ))
-            ))
-         format))
-

 (defvar mime-echo-window-is-shared-with-bbdb t
   "*If non-nil, mime-echo window is shared with BBDB window.")
 
 (defvar mime-echo-window-is-shared-with-bbdb t
   "*If non-nil, mime-echo window is shared with BBDB window.")
 

@@ -341,69 +291,99 @@ window.")
   (concat (regexp-* mime-view-file-name-char-regexp)
          "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 
   (concat (regexp-* mime-view-file-name-char-regexp)
          "\\(\\." mime-view-file-name-char-regexp "+\\)*"))
 

-(defun mime-raw-get-original-filename (param)
-  (or (if (member (cdr (assq 'encoding param))
-                 mime-view-uuencode-encoding-name-list)
-         (mime-raw-get-uu-filename))
-      (let (ret)
-       (or (if (or (and (setq ret (mime-read-Content-Disposition))
-                        (setq ret
-                              (assoc
-                               "filename"
-                               (mime-content-disposition-parameters ret)))
-                        )
-                   (setq ret (assoc "name" param))
-                   (setq ret (assoc "x-name" param))
-                   )
-               (std11-strip-quoted-string (cdr ret))
-             )
-           (if (setq ret
-                     (std11-find-field-body '("Content-Description"
-                                              "Subject")))
-               (if (or (string-match mime-view-file-name-regexp-1 ret)
-                       (string-match mime-view-file-name-regexp-2 ret))
-                   (substring ret (match-beginning 0)(match-end 0))
-                 ))
-           ))
-      ))
-
-(defun mime-raw-get-filename (param)
-  (replace-as-filename (mime-raw-get-original-filename param))
-  )
+(defun mime-entity-safe-filename (entity)
+  (let ((filename
+        (or (mime-entity-filename entity)
+            (let ((subj
+                   (or (mime-read-field 'Content-Description entity)
+                       (mime-read-field 'Subject entity))))
+              (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))
+                )))))
+    (if filename
+       (replace-as-filename filename)
+      )))

 
 
 ;;; @ file extraction
 ;;;
 
 
 
 ;;; @ file extraction
 ;;;
 

-(defun mime-method-to-save (entity cal)
+(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)))))))
+        )
+    (if (file-exists-p filename)
+       (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
+           (error "")))
+    (mime-write-entity-content entity filename)
+    ))
+
+
+;;; @ file detection
+;;;
+
+(defvar mime-file-content-type-alist
+  '(("JPEG"            image jpeg)
+    ("GIF"             image gif)
+    ("Standard MIDI"   audio midi)
+    )
+  "*Alist of \"file\" output patterns vs. corresponding media-types.
+Each element looks like (REGEXP TYPE SUBTYPE).
+REGEXP is pattern for \"file\" command output.
+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)
   (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-raw-get-filename cal)
+                  (mime-entity-safe-filename entity)

                   ))
                   ))

-          (encoding (or (cdr (assq 'encoding cal)) "7bit"))
+          (encoding (or (cdr (assq 'encoding situation)) "7bit"))

           (filename (if (and name (not (string-equal name "")))
           (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)))))))
-          )
-      (if (file-exists-p filename)
-         (or (yes-or-no-p (format "File %s exists. Save anyway? " filename))
-             (error "")))
-      (re-search-forward "\n\n")
-      (mime-write-decoded-region (match-end 0) end filename encoding)
+                        (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))))
+         ))

       )))
 
 
       )))
 
 

@@ -422,50 +402,27 @@ It is registered to variable `mime-preview-quitting-method-alist'."
     (pop-to-buffer mother)
     ))
 
     (pop-to-buffer mother)
     ))
 

-(defun mime-method-to-display-message/rfc822 (entity cal)
-  (let* ((beg (mime-entity-point-min entity))
-        (end (mime-entity-point-max entity))
-        (cnum (mime-raw-point-to-entity-number beg))
-        (new-name (format "%s-%s" (buffer-name) cnum))
+(defun mime-view-message/rfc822 (entity situation)
+  (let* ((new-name
+         (format "%s-%s" (buffer-name) (mime-entity-number entity)))

         (mother mime-preview-buffer)
         (mother mime-preview-buffer)

-        (representation-type
-         (cdr (or (assq major-mode mime-raw-representation-type-alist)
-                  (assq t mime-raw-representation-type-alist))))
-        str)
-    (setq str (buffer-substring beg end))
-    (switch-to-buffer new-name)
+        (children (car (mime-entity-children entity))))
+    (set-buffer (get-buffer-create new-name))

     (erase-buffer)
     (erase-buffer)

-    (insert str)
-    (goto-char (point-min))
-    (if (re-search-forward "^\n" nil t)
-       (delete-region (point-min) (match-end 0))
-      )
+    (insert-buffer-substring (mime-entity-buffer children)
+                            (mime-entity-point-min children)
+                            (mime-entity-point-max children))
+    (setq mime-message-structure children)

     (setq major-mode 'mime-show-message-mode)
     (setq major-mode 'mime-show-message-mode)

-    (setq mime-raw-representation-type representation-type)
-    (mime-view-mode mother)
+    (mime-view-buffer (current-buffer) nil mother
+                     nil (if (mime-entity-cooked-p entity) 'cooked))

     ))
 
 
 ;;; @ message/partial
 ;;;
 
     ))
 
 
 ;;; @ message/partial
 ;;;
 

-(defun mime-raw-write-region (start end filename)
-  "Write current region into specified file.
-When called from a program, takes three arguments:
-START, END and FILENAME.  START and END are buffer positions.
-It refer `mime-raw-representation-type' or `major-mode
-mime-raw-representation-type-alist'.  If it is `binary', region is
-saved as binary.  Otherwise the region is saved by `write-region'."
-  (let ((presentation-type
-        (or mime-raw-representation-type
-            (cdr (or (assq major-mode mime-raw-representation-type-alist)
-                     (assq t mime-raw-representation-type-alist))))))
-    (if (eq presentation-type 'binary)
-       (write-region-as-binary start end filename)
-      (write-region start end filename)
-      )))
-
-(defun mime-method-to-store-message/partial (entity cal)
+(defun mime-store-message/partial-piece (entity cal)

   (goto-char (mime-entity-point-min entity))
   (let* ((root-dir
          (expand-file-name
   (goto-char (mime-entity-point-min entity))
   (let* ((root-dir
          (expand-file-name

@@ -503,10 +460,8 @@ saved as binary.  Otherwise the region is saved by `write-region'."
                               mime-preview-buffer))
          (select-window pwin)
          )
                               mime-preview-buffer))
          (select-window pwin)
          )

-      (re-search-forward "^$")
-      (goto-char (1+ (match-end 0)))

       (setq file (concat root-dir "/" number))
       (setq file (concat root-dir "/" number))

-      (mime-raw-write-region (point) (mime-entity-point-max entity) file)
+      (mime-write-entity-body entity file)

       (let ((total-file (concat root-dir "/CT")))
        (setq total
              (if total
       (let ((total-file (concat root-dir "/CT")))
        (setq total
              (if total

@@ -597,22 +552,29 @@ saved as binary.  Otherwise the region is saved by `write-region'."
     (dired dir)
     ))
 
     (dired dir)
     ))
 

-(defun mime-method-to-display-message/external-ftp (entity cal)
+(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)))
   (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 (concat "Accessing " (expand-file-name name pathname) " ..."))

     (funcall mime-raw-dired-function pathname)
     (goto-char (point-min))
     (search-forward name)
     ))
 
     (funcall mime-raw-dired-function pathname)
     (goto-char (point-min))
     (search-forward name)
     ))
 

+(defvar mime-raw-browse-url-function (function mime-browse-url))
+
+(defun mime-view-message/external-url (entity cal)
+  (let ((url (cdr (assoc "url" cal))))
+    (message (concat "Accessing " url " ..."))
+    (funcall mime-raw-browse-url-function url)))
+

 
 ;;; @ rot13-47
 ;;;
 
 
 ;;; @ rot13-47
 ;;;
 

-(defun mime-method-to-display-caesar (entity situation)
+(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)))
   "Internal method for mime-view to display ROT13-47-48 message."
   (let* ((new-name (format "%s-%s" (buffer-name)
                           (mime-entity-number entity)))