X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-play.el;h=25610c09424e36de27944af1911afb6a27dba6cf;hb=175f60a046597d28407ae8eded0bfa8fe23f2411;hp=c3c1979aedcf72475b458729130403e42e7b4cca;hpb=804ff25754c6373b7024524cb566d3331b55e023;p=elisp%2Fsemi.git diff --git a/mime-play.el b/mime-play.el index c3c1979..25610c0 100644 --- a/mime-play.el +++ b/mime-play.el @@ -34,10 +34,12 @@ (require 'mime-text) (condition-case nil (require 'bbdb) - (error (defvar bbdb-buffer-name nil)) - )) + (error (defvar bbdb-buffer-name nil))) + ) + +(defvar mime-acting-situation-example-list nil) -(defvar mime-acting-situation-examples nil) +(defvar mime-acting-situation-example-list-max-size 16) (defun mime-save-acting-situation-examples () (let* ((file mime-acting-situation-examples-file) @@ -51,8 +53,8 @@ (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) + (pp `(setq mime-acting-situation-example-list + ',mime-acting-situation-example-list) (current-buffer)) (insert "\n;;; " (file-name-nondirectory file) @@ -62,27 +64,74 @@ (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))) + ) + ((= 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)) + )))) + + ;;; @ content decoder ;;; (defvar mime-preview-after-decoded-position nil) -(defun mime-preview-play-current-entity (&optional mode) +(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) - (or mode - (setq mode "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) + (mime-raw-play-entity entity (or mode "play") nil ignore-examples) (when (eq (current-buffer) raw-buffer) (set-buffer the-buf) (goto-char mime-preview-after-decoded-position) @@ -123,17 +172,39 @@ 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) + )) + +(defun mime-raw-play-entity (entity &optional mode situation ignore-examples + 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 @@ -144,21 +215,66 @@ specified, play as it. Default MODE is \"play\"." (if mode (setq situation (cons (cons 'mode mode) situation)) ) + (if ignore-examples + (or (assq 'ignore-examples situation) + (setq situation + (cons (cons 'ignore-examples ignore-examples) 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 situation + mime-view-find-every-acting-situation) + 'method ignored-method)) + (or ignore-examples + (if (cdr ret) + (let ((rest ret) + (max-score 0) + max-escore + 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" @@ -170,7 +286,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)) @@ -206,10 +322,14 @@ specified, play as it. Default MODE is \"play\"." (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 @@ -232,53 +352,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 (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.") @@ -336,113 +409,100 @@ 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 (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) - ))) +(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-type-regexp-type-subtype-alist - '(("JPEG" image jpeg))) - -(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-type-regexp-type-subtype-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)))) - )) - ))) +(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 regexp about magic-number vs. corresponding media-types. +Each element looks like (REGEXP TYPE SUBTYPE). +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 (type subtype) + (let ((mdata (save-excursion + ;;(set-buffer (mime-entity-buffer entity)) + (let* ((start (mime-entity-body-start entity)) + (end (progn + (goto-char start) + (end-of-line) + (point)))) + (mime-decode-string (buffer-substring start end) + (mime-entity-encoding 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-raw-play-entity + entity nil + (put-alist 'type type + (put-alist 'subtype subtype + (del-alist 'method + (copy-alist situation)))) + (cdr (assq 'ignore-examples situation)) + 'mime-detect-content) + )) + ) ;;; @ mail/news message @@ -460,50 +520,27 @@ It is registered to variable `mime-preview-quitting-method-alist'." (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) - (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) - (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 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 ;;; -(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 @@ -533,7 +570,7 @@ saved as binary. Otherwise the region is saved by `write-region'." (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 @@ -541,10 +578,8 @@ 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) (mime-entity-point-max entity) file) + (mime-write-entity-body entity file) (let ((total-file (concat root-dir "/CT"))) (setq total (if total @@ -605,11 +640,10 @@ saved as binary. Otherwise the region is saved by `write-region'." )) (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))) @@ -635,22 +669,29 @@ saved as binary. Otherwise the region is saved by `write-region'." (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))) - (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) )) +(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 (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))) @@ -687,8 +728,15 @@ saved as binary. Otherwise the region is saved by `write-region'." (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))))