X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=45ff40d8ea0c01831612a3cd9f285255e2b85683;hb=1205609bb5356548d83755c021f1024260d7e142;hp=0df9aec47b8d568cbed8595988adabb462cfce57;hpb=3452db500df17b8365d8f4a5369cba22941684fd;p=elisp%2Fsemi.git diff --git a/mime-play.el b/mime-play.el index 0df9aec..45ff40d 100644 --- a/mime-play.el +++ b/mime-play.el @@ -30,6 +30,38 @@ (require 'alist) (require 'filename) +(eval-when-compile + (require 'mime-text) + (condition-case nil + (require 'bbdb) + (error (defvar bbdb-buffer-name nil)) + )) + +(defvar mime-acting-situation-examples nil) + +(defun mime-save-acting-situation-examples () + (let* ((file mime-acting-situation-examples-file) + (buffer (get-buffer-create " *mime-example*"))) + (unwind-protect + (save-excursion + (set-buffer buffer) + (setq buffer-file-name file) + (erase-buffer) + (insert ";;; " (file-name-nondirectory file) "\n") + (insert "\n;; This file is generated automatically by " + mime-view-version-string "\n\n") + (insert ";;; Code:\n\n") + (pp `(setq mime-acting-situation-examples + ',mime-acting-situation-examples) + (current-buffer)) + (insert "\n;;; " + (file-name-nondirectory file) + " ends here.\n") + (save-buffer)) + (kill-buffer buffer)))) + +(add-hook 'kill-emacs-hook 'mime-save-acting-situation-examples) + ;;; @ content decoder ;;; @@ -43,132 +75,209 @@ 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 ((cinfo (get-text-property (point) 'mime-view-cinfo))) - (if cinfo + (setq mode "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-playback-entity cinfo mode) - (if (eq (current-buffer) raw-buffer) - (progn - (set-buffer the-buf) - (goto-char mime-preview-after-decoded-position) - )) - )))) - -(defun mime-playback-entity (cinfo &optional mode) - (let ((beg (mime-entity-info-point-min cinfo)) - (end (mime-entity-info-point-max cinfo)) - (c-type (mime-entity-info-media-type cinfo)) - (c-subtype (mime-entity-info-media-subtype cinfo)) - (params (mime-entity-info-parameters cinfo)) - (encoding (mime-entity-info-encoding cinfo)) - ) - (or c-type - (setq c-type 'text - c-subtype 'plain)) - ;; Check for VM - (if (< beg (point-min)) - (setq beg (point-min)) - ) - (if (< (point-max) end) - (setq end (point-max)) - ) - (let (method cal ret) - (setq cal (list* (cons 'type c-type) - (cons 'subtype c-subtype) - (cons 'encoding encoding) - (cons 'major-mode major-mode) - params)) - (if mode - (setq cal (cons (cons 'mode mode) cal)) - ) - (setq ret (mime/get-content-decoding-alist cal)) - (setq method (cdr (assq 'method ret))) - (cond ((and (symbolp method) - (fboundp method)) - (funcall 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" ctype) - )) + (mime-raw-play-entity entity mode) + (when (eq (current-buffer) raw-buffer) + (set-buffer the-buf) + (goto-char mime-preview-after-decoded-position) + ))))) + +(defun mime-sort-situation (situation) + (sort situation + #'(lambda (a b) + (let ((a-t (car a)) + (b-t (car b)) + (order '((type . 1) + (subtype . 2) + (mode . 3) + (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 7) + )) + (setq a-order 8) + ) + (if (symbolp b-t) + (let ((ret (assq b-t order))) + (if ret + (setq b-order (cdr ret)) + (setq b-order 7) + )) + (setq b-order 8) + ) + (if (= a-order b-order) + (string< (format "%s" a-t)(format "%s" b-t)) + (< a-order b-order)) + ))) + ) + +(defsubst mime-delq-null-situation (situations field) + (let (dest) + (while situations + (let ((situation (car situations))) + (if (assq field situation) + (setq dest (cons situation dest)) + )) + (setq situations (cdr situations))) + dest)) + +(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 (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)) + )) )) -;;; @ method selector -;;; - -(defun mime/get-content-decoding-alist (al) - (get-unified-alist mime-acting-condition al) - ) - - ;;; @ external decoder ;;; -(defun mime-activate-external-method (beg end cal) +(defvar mime-mailcap-method-filename-alist nil) + +(defun mime-activate-mailcap-method (entity situation) (save-excursion (save-restriction - (narrow-to-region beg end) - (goto-char beg) - (let ((method (cdr (assoc 'method cal))) - (name (mime-article/get-filename cal)) + (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 (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))) + (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) ) - (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)) + ))))) + +(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))) + +;; (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 (mime-entity-body-start entity))) +;; (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)))) +;; (or 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.") @@ -196,7 +305,7 @@ window.") (setq win (get-buffer-window bbdb-buffer-name)) ) (set-window-buffer win mime-echo-buffer-name) - (select-window (get-buffer-window mime-view-buffer)) + (select-window (get-buffer-window mime-preview-buffer)) (setq win (split-window-vertically (- (window-height) (if (functionp mime-echo-window-height) @@ -227,11 +336,16 @@ window.") (concat (regexp-* mime-view-file-name-char-regexp) "\\(\\." mime-view-file-name-char-regexp "+\\)*")) -(defun mime-article/get-original-filename (param &optional encoding) - (or (mime-article/get-uu-filename param encoding) +(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/Content-Disposition)) - (setq ret (assoc "filename" (cdr 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)) @@ -248,52 +362,104 @@ window.") )) )) -(defun mime-article/get-filename (param) - (replace-as-filename (mime-article/get-original-filename param)) +(defun mime-raw-get-filename (param) + (replace-as-filename (mime-raw-get-original-filename param)) ) ;;; @ file extraction ;;; -(defun mime-method-to-save (beg end cal) - (goto-char beg) - (let* ((name - (save-restriction - (narrow-to-region beg end) - (mime-article/get-filename cal) - )) - (encoding (cdr (assq 'encoding cal))) - (filename - (if (and name (not (string-equal name ""))) - (expand-file-name name - (call-interactively - (function - (lambda (dir) - (interactive "DDirectory: ") - dir)))) - (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)(point-max) filename encoding) - )) +(defun mime-method-to-save (entity cal) + (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) + )) + (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))))))) + ) + (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) + ))) + + +;;; @ 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-method-to-detect (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-raw-get-filename situation) + )) + (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 ;;; -(defun mime-view-quitting-method-for-mime-show-message-mode () +(defun mime-preview-quitting-method-for-mime-show-message-mode () "Quitting method for mime-view. -It is registered to variable `mime-view-quitting-method-alist'." +It is registered to variable `mime-preview-quitting-method-alist'." (let ((mother mime-mother-buffer) - (win-conf mime::preview/original-window-configuration) + (win-conf mime-preview-original-window-configuration) ) (kill-buffer mime-raw-buffer) (mime-preview-kill-buffer) @@ -301,13 +467,15 @@ It is registered to variable `mime-view-quitting-method-alist'." (pop-to-buffer mother) )) -(defun mime-method-to-display-message/rfc822 (beg end cal) - (let* ((cnum (mime-article/point-content-number beg)) +(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)) - (mother mime-view-buffer) - (text-decoder - (cdr (or (assq major-mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist)))) + (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) @@ -318,7 +486,7 @@ It is registered to variable `mime-view-quitting-method-alist'." (delete-region (point-min) (match-end 0)) ) (setq major-mode 'mime-show-message-mode) - (setq mime-text-decoder text-decoder) + (setq mime-raw-representation-type representation-type) (mime-view-mode mother) )) @@ -326,22 +494,24 @@ It is registered to variable `mime-view-quitting-method-alist'." ;;; @ message/partial ;;; -(defvar mime-article/coding-system-alist - (list '(mh-show-mode . no-conversion) - (cons t (mime-charset-to-coding-system default-mime-charset)) - )) - -(defun mime-article::write-region (start end file) - (let ((coding-system-for-write - (cdr - (or (assq major-mode mime-article/coding-system-alist) - (assq t mime-article/coding-system-alist) - )))) - (write-region start end file) - )) +(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 (beg end cal) - (goto-char beg) +(defun mime-method-to-store-message/partial (entity cal) + (goto-char (mime-entity-point-min entity)) (let* ((root-dir (expand-file-name (concat "m-prts-" (user-login-name)) mime-temp-directory)) @@ -349,8 +519,8 @@ It is registered to variable `mime-view-quitting-method-alist'." (number (cdr (assoc "number" cal))) (total (cdr (assoc "total" cal))) file - (mother mime-view-buffer) - ) + (mother mime-preview-buffer) + ) (or (file-exists-p root-dir) (make-directory root-dir) ) @@ -375,13 +545,13 @@ It is registered to variable `mime-view-quitting-method-alist'." (set-window-buffer pwin (save-excursion (set-buffer full-buf) - mime-view-buffer)) + mime-preview-buffer)) (select-window pwin) ) (re-search-forward "^$") (goto-char (1+ (match-end 0))) (setq file (concat root-dir "/" number)) - (mime-article::write-region (point) end file) + (mime-raw-write-region (point) (mime-entity-point-max entity) file) (let ((total-file (concat root-dir "/CT"))) (setq total (if total @@ -426,8 +596,8 @@ It is registered to variable `mime-view-quitting-method-alist'." (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))) @@ -449,7 +619,7 @@ It is registered to variable `mime-view-quitting-method-alist'." )) (pbuf (save-excursion (set-buffer full-buf) - mime-view-buffer))) + mime-preview-buffer))) (set-window-buffer pwin pbuf) (select-window pwin) ))))) @@ -459,28 +629,26 @@ It is registered to variable `mime-view-quitting-method-alist'." ;;; @ message/external-body ;;; -(defvar mime-article/dired-function - (if mime/use-multi-frame +(defvar mime-raw-dired-function + (if (and (>= emacs-major-version 19) window-system) (function dired-other-frame) - (function mime-article/dired-function-for-one-frame) + (function mime-raw-dired-function-for-one-frame) )) -(defun mime-article/dired-function-for-one-frame (dir) - (let ((win (or (get-buffer-window mime-view-buffer) +(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) )) -(defun mime-method-to-display-message/external-ftp (beg end cal) +(defun mime-method-to-display-message/external-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)) - ) + (pathname (concat "/anonymous@" site ":" directory))) (message (concat "Accessing " (expand-file-name name pathname) "...")) - (funcall mime-article/dired-function pathname) + (funcall mime-raw-dired-function pathname) (goto-char (point-min)) (search-forward name) )) @@ -489,36 +657,21 @@ It is registered to variable `mime-view-quitting-method-alist'." ;;; @ rot13-47 ;;; -(defun mime-method-to-display-caesar (start end cal) +(defun mime-method-to-display-caesar (entity situation) "Internal method for mime-view to display ROT13-47-48 message." - (let* ((cnum (mime-article/point-content-number start)) - (new-name (format "%s-%s" (buffer-name) cnum)) - (the-buf (current-buffer)) - (mother mime-view-buffer) - (charset (cdr (assoc "charset" cal))) - (encoding (cdr (assq 'encoding cal))) - (mode major-mode) - ) + (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)) - ) + (buf (get-buffer-create new-name))) (set-window-buffer pwin buf) (set-buffer buf) (select-window pwin) ) (setq buffer-read-only nil) (erase-buffer) - (insert-buffer-substring the-buf start end) - (goto-char (point-min)) - (if (re-search-forward "^\n" nil t) - (delete-region (point-min) (match-end 0)) - ) - (let ((m (cdr (or (assq mode mime-text-decoder-alist) - (assq t mime-text-decoder-alist))))) - (and (functionp m) - (funcall m charset encoding) - )) + (mime-text-insert-decoded-body entity) (mule-caesar-region (point-min) (point-max)) (set-buffer-modified-p nil) (set-buffer mother) @@ -531,4 +684,19 @@ It is registered to variable `mime-view-quitting-method-alist'." (provide 'mime-play) +(let* ((file mime-acting-situation-examples-file) + (buffer (get-buffer-create " *mime-example*"))) + (if (file-readable-p file) + (unwind-protect + (save-excursion + (set-buffer buffer) + (erase-buffer) + (insert-file-contents file) + (eval-buffer) + ;; format check + (or (eq (car mime-acting-situation-examples) 'type) + (setq mime-acting-situation-examples nil)) + ) + (kill-buffer buffer)))) + ;;; mime-play.el ends here