X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=f9834bd2fcf7a457fd13c5230f6e34f847af82e3;hb=7ea83da02b92096b3506f881c689ea7f03a84f53;hp=da9d9c866a14a06964933bcc83f733ed68771df5;hpb=bf585d86080c69a216de952a4fe863ed3dd4bd71;p=elisp%2Fsemi.git diff --git a/mime-play.el b/mime-play.el index da9d9c8..f9834bd 100644 --- a/mime-play.el +++ b/mime-play.el @@ -34,8 +34,8 @@ (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) @@ -73,16 +73,14 @@ 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")) - (let ((entity-info (get-text-property (point) 'mime-view-entity))) - (if entity-info + (interactive (list "play")) + (let ((entity (get-text-property (point) 'mime-view-entity))) + (if entity (let ((the-buf (current-buffer)) - (raw-buffer (get-text-property (point) 'mime-view-raw-buffer))) + (raw-buffer (mime-entity-buffer entity))) (setq mime-preview-after-decoded-position (point)) (set-buffer raw-buffer) - (mime-raw-play-entity entity-info mode) + (mime-raw-play-entity entity mode) (when (eq (current-buffer) raw-buffer) (set-buffer the-buf) (goto-char mime-preview-after-decoded-position) @@ -96,23 +94,26 @@ If MODE is specified, play as it. Default MODE is \"play\"." (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)) - (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)) - (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)) @@ -130,74 +131,64 @@ If MODE is specified, play as it. Default MODE is \"play\"." (setq situations (cdr situations))) dest)) -(defun mime-raw-play-entity (entity-info &optional mode) - "Play entity specified by ENTITY-INFO. +(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\"." - (let ((beg (mime-entity-point-min entity-info)) - (end (mime-entity-point-max entity-info)) - (content-type (mime-entity-content-type entity-info)) - (encoding (mime-entity-encoding entity-info))) - (or content-type - (setq content-type (make-mime-content-type 'text 'plain))) - (let (method cal ret) - (setq cal (list* (cons 'major-mode major-mode) - (cons 'encoding encoding) - content-type)) - (if mode - (setq cal (cons (cons 'mode mode) cal)) - ) - (setq ret - (or (ctree-match-calist mime-acting-situation-examples cal) - (ctree-match-calist-partially mime-acting-situation-examples - cal) - cal)) - (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 - mime-view-find-every-acting-situation) - 'method) - )) - (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)) - (ctree-set-calist-strictly 'mime-acting-situation-examples ret) - ) - (t - (setq ret (car ret)) - )) - (setq method (cdr (assq 'method ret))) - (cond ((and (symbolp method) - (fboundp method)) - (funcall method beg end ret) - ) - ((stringp method) - (mime-activate-mailcap-method beg end ret) - ) - ((and (listp method)(stringp (car method))) - (mime-activate-external-method beg end ret) - ) - (t - (mime-show-echo-buffer - "No method are specified for %s\n" - (mime-type/subtype-string - (mime-content-type-primary-type content-type) - (mime-content-type-subtype content-type)) - ))) - ))) + (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) + )) + (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)) + (ctree-set-calist-strictly 'mime-acting-situation-examples ret) + ) + (t + (setq ret (car ret)) + )) + (setq method (cdr (assq 'method ret))) + (cond ((and (symbolp method) + (fboundp method)) + (funcall method entity ret) + ) + ((stringp method) + (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-entity-type/subtype entity)) + )) + )) ;;; @ external decoder @@ -205,33 +196,36 @@ specified, play as it. Default MODE is \"play\"." (defvar mime-mailcap-method-filename-alist nil) -(defun mime-activate-mailcap-method (start end situation) +(defun mime-activate-mailcap-method (entity situation) (save-excursion (save-restriction - (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 (if (re-search-forward "^$" end t) - (1+ (match-end 0)) - (point-min)) - end name - (cdr (assq 'encoding situation))) - (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) - ) - ;;(mime-show-echo-buffer) - )))) + (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 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 + name (cdr (assq 'encoding situation))) + (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)))) @@ -241,61 +235,6 @@ specified, play as it. Default MODE is \"play\"." (remove-alist 'mime-mailcap-method-filename-alist process) (message (format "%s %s" process event))) -(defun mime-activate-external-method (beg end cal) - (save-excursion - (save-restriction - (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.") @@ -353,72 +292,102 @@ window.") (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 ;;; -(defun mime-method-to-save (beg end cal) - (goto-char beg) - (let* ((name - (save-restriction - (narrow-to-region beg end) - (mime-raw-get-filename cal) - )) - (encoding (or (cdr (assq 'encoding cal)) "7bit")) - (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))))))) +(defun mime-save-content (entity situation) + (let* ((name (mime-entity-safe-filename entity)) + (encoding (or (mime-entity-encoding entity) "7bit")) + (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) + (or (yes-or-no-p (format "File %s exists. Save anyway? " filename)) + (error ""))) + (mime-write-decoded-region (mime-entity-body-start entity) + (mime-entity-body-end entity) + filename encoding) )) +;;; @ file detection +;;; + +(defvar mime-file-content-type-alist + '(("JPEG" image jpeg) + ("GIF" image gif) + ) + "*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) + (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 (looking-at (car cell)) + (setq type (nth 1 cell) + subtype (nth 2 cell)) + ))) + (setq rest (cdr rest)))))) + (if type + (mime-raw-play-entity + entity "play" + (put-alist 'type type + (put-alist 'subtype subtype + (mime-entity-situation entity)))) + )) + ))) + + ;;; @ mail/news message ;;; @@ -434,13 +403,13 @@ It is registered to variable `mime-preview-quitting-method-alist'." (pop-to-buffer mother) )) -(defun mime-method-to-display-message/rfc822 (beg end cal) - (let* ((cnum (mime-raw-point-to-entity-number beg)) +(defun mime-view-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)) (mother mime-preview-buffer) - (representation-type - (cdr (or (assq major-mode mime-raw-representation-type-alist) - (assq t mime-raw-representation-type-alist)))) + (representation-type (mime-entity-representation-type entity)) str) (setq str (buffer-substring beg end)) (switch-to-buffer new-name) @@ -475,8 +444,8 @@ saved as binary. Otherwise the region is saved by `write-region'." (write-region start end filename) ))) -(defun mime-method-to-store-message/partial (beg end cal) - (goto-char beg) +(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)) @@ -485,7 +454,7 @@ saved as binary. Otherwise the region is saved by `write-region'." (total (cdr (assoc "total" cal))) file (mother mime-preview-buffer) - ) + ) (or (file-exists-p root-dir) (make-directory root-dir) ) @@ -513,10 +482,9 @@ saved as binary. Otherwise the region is saved by `write-region'." mime-preview-buffer)) (select-window pwin) ) - (re-search-forward "^$") - (goto-char (1+ (match-end 0))) (setq file (concat root-dir "/" number)) - (mime-raw-write-region (point) end file) + (mime-raw-write-region (mime-entity-body-start entity) + (mime-entity-body-end entity) file) (let ((total-file (concat root-dir "/CT"))) (setq total (if total @@ -561,8 +529,8 @@ saved as binary. Otherwise the region is saved by `write-region'." (setq i (1+ i)) )) (as-binary-output-file - (write-region (point-min)(point-max) - (expand-file-name "FULL" root-dir))) + (write-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))) @@ -607,27 +575,31 @@ saved as binary. Otherwise the region is saved by `write-region'." (dired dir) )) -(defun mime-method-to-display-message/external-ftp (beg end 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))) - ;;(mode (cdr (assoc "mode" cal))) - (pathname (concat "/anonymous@" site ":" directory)) - ) - (message (concat "Accessing " (expand-file-name name pathname) "...")) + (pathname (concat "/anonymous@" site ":" directory))) + (message (concat "Accessing " (expand-file-name name pathname) " ...")) (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 ;;; -(defun mime-method-to-display-caesar (start end cal) +(defun mime-view-caesar (entity situation) "Internal method for mime-view to display ROT13-47-48 message." - (let* ((entity (mime-raw-find-entity-from-point start)) - (new-name (format "%s-%s" (buffer-name) + (let* ((new-name (format "%s-%s" (buffer-name) (mime-entity-number entity))) (mother mime-preview-buffer)) (let ((pwin (or (get-buffer-window mother)