X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=d735ea5b04da20ab56ce0d66ccb99b0c69af1ea9;hb=f362b657a215832be13521aad8ce7083950bebd7;hp=adba83303fa3700e582578f568c3f5d2dceeb1f1;hpb=7d7dd0b2bc9737193a25f42a082eb95d809615a0;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index adba833..d735ea5 100644 --- a/mime-view.el +++ b/mime-view.el @@ -33,6 +33,7 @@ (require 'mime-parse) (require 'semi-def) (require 'calist) +(require 'mailcap) ;;; @ version @@ -44,6 +45,24 @@ " (" (cadr mime-module-version) ")")) +;;; @ variables +;;; + +(defgroup mime-view nil + "MIME view mode" + :group 'mime) + +(defcustom mime-view-find-every-acting-situation t + "*Find every available acting-situation if non-nil." + :group 'mime-view + :type 'boolean) + +(defcustom mime-acting-situation-examples-file "~/.mime-example" + "*File name of example about acting-situation demonstrated by user." + :group 'mime-view + :type 'file) + + ;;; @ buffer local variables ;;; @@ -75,6 +94,18 @@ message/rfc822, `mime-entity' structures of them are included in "MIME-preview buffer corresponding with the (raw) buffer.") (make-variable-buffer-local 'mime-preview-buffer) +(defvar mime-raw-representation-type-alist + '((mime-show-message-mode . binary) + (mime-temp-message-mode . binary) + (t . cooked) + ) + "Alist of major-mode vs. representation-type of mime-raw-buffer. +Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is +major-mode or t. t means default. REPRESENTATION-TYPE must be +`binary' or `cooked'. +This value is overridden by buffer local variable +`mime-raw-representation-type' if it is not nil.") + ;;; @@ in preview-buffer ;;; @@ -261,21 +292,6 @@ Please redefine this function if you want to change default setting." ;;; @@ entity-header ;;; -;;; @@@ predicate function -;;; - -;; (defvar mime-view-childrens-header-showing-Content-Type-list -;; '("message/rfc822" "message/news")) - -;; (defun mime-view-header-visible-p (entity message-info) -;; "Return non-nil if header of ENTITY is visible." -;; (let ((entity-node-id (mime-entity-node-id entity))) -;; (member (mime-entity-type/subtype -;; (mime-raw-find-entity-from-node-id -;; (cdr entity-node-id) message-info)) -;; mime-view-childrens-header-showing-Content-Type-list) -;; )) - ;;; @@@ entity header filter ;;; @@ -387,40 +403,38 @@ Each elements are regexp of field-name.") (body . visible))) (ctree-set-calist-strictly - 'mime-preview-condition '((body . visible) - (body-presentation-method . with-filter) - (body-filter . mime-preview-filter-for-text/plain))) + 'mime-preview-condition + '((body . visible) + (body-presentation-method . mime-preview-text/plain))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . nil) - (body . visible) - (body-presentation-method . with-filter) - (body-filter . mime-preview-filter-for-text/plain))) + 'mime-preview-condition + '((type . nil) + (body . visible) + (body-presentation-method . mime-preview-text/plain))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . text)(subtype . enriched) - (body . visible) - (body-presentation-method . with-filter) - (body-filter - . mime-preview-filter-for-text/enriched))) + 'mime-preview-condition + '((type . text)(subtype . enriched) + (body . visible) + (body-presentation-method . mime-preview-text/enriched))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . text)(subtype . richtext) - (body . visible) - (body-presentation-method . with-filter) - (body-filter - . mime-preview-filter-for-text/richtext))) + 'mime-preview-condition + '((type . text)(subtype . richtext) + (body . visible) + (body-presentation-method . mime-preview-text/richtext))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . text)(subtype . t) - (body . visible) - (body-presentation-method . with-filter) - (body-filter . mime-preview-filter-for-text/plain))) + 'mime-preview-condition + '((type . text)(subtype . t) + (body . visible) + (body-presentation-method . mime-preview-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . message)(subtype . partial) (body-presentation-method - . mime-view-insert-message/partial-button))) + . mime-preview-message/partial-button))) (ctree-set-calist-strictly 'mime-preview-condition '((type . message)(subtype . rfc822) @@ -435,28 +449,12 @@ Each elements are regexp of field-name.") (entity-button . invisible)))) -;;; @@@ entity filter +;;; @@@ entity presentation ;;; -(autoload 'mime-preview-filter-for-text/plain "mime-text") -(autoload 'mime-preview-filter-for-text/enriched "mime-text") -(autoload 'mime-preview-filter-for-text/richtext "mime-text") - -(defvar mime-text-decoder-alist - '((mime-show-message-mode . mime-text-decode-buffer) - (mime-temp-message-mode . mime-text-decode-buffer) - (t . mime-text-decode-buffer-maybe) - ) - "Alist of major-mode vs. mime-text-decoder. -Each element looks like (SYMBOL . FUNCTION). SYMBOL is major-mode or -t. t means default. - -Specification of FUNCTION is described in DOC-string of variable -`mime-text-decoder'. - -This value is overridden by buffer local variable `mime-text-decoder' -if it is not nil.") - +(autoload 'mime-preview-text/plain "mime-text") +(autoload 'mime-preview-text/enriched "mime-text") +(autoload 'mime-preview-text/richtext "mime-text") (defvar mime-view-announcement-for-message/partial (if (and (>= emacs-major-version 19) window-system) @@ -469,7 +467,7 @@ if it is not nil.") \[[ Please press `v' key in this buffer. ]]" )) -(defun mime-view-insert-message/partial-button (&optional situation) +(defun mime-preview-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) @@ -482,69 +480,145 @@ if it is not nil.") #'mime-preview-play-current-entity) )) +(defun mime-preview-multipart/mixed (entity situation) + (let ((children (mime-entity-children entity)) + (default-situation + (cdr (assq 'childrens-situation situation)))) + (while children + (mime-view-display-entity (car children) mime-raw-message-info + mime-raw-buffer (current-buffer) + default-situation) + (setq children (cdr children)) + ))) + ;;; @ acting-condition ;;; -(defvar mime-acting-condition - '(((type . text)(subtype . plain) - (method "tm-plain" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . text)(subtype . html) - (method "tm-html" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - ((type . text)(subtype . x-rot13-47) - (method . mime-method-to-display-caesar) - (mode . "play") - ) - ((type . text)(subtype . x-rot13-47-48) - (method . mime-method-to-display-caesar) - (mode . "play") - ) - - ((type . audio)(subtype . basic) - (method "tm-au" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . image) - (method "tm-image" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - - ((type . video)(subtype . mpeg) - (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name) - (mode . "play") - ) - - ((type . application)(subtype . postscript) - (method "tm-ps" nil 'file "" 'encoding 'mode 'name) - (mode "play" "print") - ) - ((type . application)(subtype . octet-stream) - (method . mime-method-to-save)(mode "play" "print") - ) - - ((type . message)(subtype . external-body) - ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) - ) - ((type . message)(subtype . rfc822) - (method . mime-method-to-display-message/rfc822) - (mode . "play") - ) - ((type . message)(subtype . partial) - (method . mime-method-to-store-message/partial) - (mode . "play") - ) - - ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - (mode . "play") - ) - ((method . mime-method-to-save)(mode . "extract")) - )) +(defvar mime-acting-condition nil + "Condition-tree about how to process entity.") + +(if (file-readable-p mailcap-file) + (let ((entries (mailcap-parse-file))) + (while entries + (let ((entry (car entries)) + view print shared) + (while entry + (let* ((field (car entry)) + (field-type (car field))) + (cond ((eq field-type 'view) (setq view field)) + ((eq field-type 'print) (setq print field)) + ((memq field-type '(compose composetyped edit))) + (t (setq shared (cons field shared)))) + ) + (setq entry (cdr entry)) + ) + (setq shared (nreverse shared)) + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared (list '(mode . "play")(cons 'method (cdr view))))) + (if print + (ctree-set-calist-with-default + 'mime-acting-condition + (append shared + (list '(mode . "print")(cons 'method (cdr view)))) + )) + ) + (setq entries (cdr entries)) + ))) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . t)(subtype . t)(mode . "extract") +;; (method . mime-method-to-save))) +(ctree-set-calist-with-default + 'mime-acting-condition + '((mode . "extract") + (method . mime-method-to-save))) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . text)(subtype . plain)(mode . "play") +;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name) +;; )) +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . text)(subtype . plain)(mode . "print") +;; (method "tm-plain" nil 'file "" 'encoding 'mode 'name) +;; )) +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . text)(subtype . html)(mode . "play") +;; (method "tm-html" nil 'file "" 'encoding 'mode 'name) +;; )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47)(mode . "play") + (method . mime-method-to-display-caesar) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . text)(subtype . x-rot13-47-48)(mode . "play") + (method . mime-method-to-display-caesar) + )) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . audio)(subtype . basic)(mode . "play") +;; (method "tm-au" nil 'file "" 'encoding 'mode 'name) +;; )) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . image)(mode . "play") +;; (method "tm-image" nil 'file "" 'encoding 'mode 'name) +;; )) +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . image)(mode . "print") +;; (method "tm-image" nil 'file "" 'encoding 'mode 'name) +;; )) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . video)(subtype . mpeg)(mode . "play") +;; (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name) +;; )) + +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . application)(subtype . postscript)(mode . "play") +;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name) +;; )) +;; (ctree-set-calist-strictly +;; 'mime-acting-condition +;; '((type . application)(subtype . postscript)(mode . "print") +;; (method "tm-ps" nil 'file "" 'encoding 'mode 'name) +;; )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . rfc822)(mode . "play") + (method . mime-method-to-display-message/rfc822) + )) +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . partial)(mode . "play") + (method . mime-method-to-store-message/partial) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("access-type" . "anon-ftp") + (method . mime-method-to-display-message/external-ftp) + )) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (method . mime-method-to-save) + )) ;;; @ quitting method @@ -609,10 +683,6 @@ The compressed face will be piped to this command.") (defvar mime-view-uuencode-encoding-name-list '("x-uue" "x-uuencode")) -(defvar mime-raw-buffer-coding-system-alist - `((t . ,(mime-charset-to-coding-system default-mime-charset))) - "Alist of major-mode vs. corresponding coding-system of `mime-raw-buffer'.") - ;;; @ buffer setup ;;; @@ -642,7 +712,11 @@ The compressed face will be piped to this command.") (setq mime-preview-original-major-mode mode) (setq major-mode 'mime-view-mode) (setq mode-name "MIME-View") - (mime-view-display-message message-info the-buf obuf) + (mime-view-display-entity message-info message-info + the-buf obuf + '((entity-button . invisible) + (header . visible) + )) (set-buffer-modified-p nil) ) (setq buffer-read-only t) @@ -651,94 +725,12 @@ The compressed face will be piped to this command.") (setq mime-preview-buffer obuf) ) -(defun mime-view-display-message (message-info ibuf obuf) - (let* ((start (mime-entity-point-min message-info)) - (end (mime-entity-point-max message-info)) - (media-type (mime-entity-media-type message-info)) - (media-subtype (mime-entity-media-subtype message-info)) - (params (mime-entity-parameters message-info)) - (encoding (mime-entity-encoding message-info)) - end-of-header e nb ne subj) - (set-buffer ibuf) - (goto-char start) - (setq end-of-header (if (re-search-forward "^$" nil t) - (1+ (match-end 0)) - end)) - (if (> end-of-header end) - (setq end-of-header end) - ) - (save-restriction - (narrow-to-region start end) - (setq subj - (eword-decode-string - (mime-raw-get-subject params encoding))) - ) - (set-buffer obuf) - (setq nb (point)) - (narrow-to-region nb nb) - ;; Insert message-header - (save-restriction - (narrow-to-region (point)(point)) - (insert-buffer-substring mime-raw-buffer start end-of-header) - (let ((f (cdr (assq mime-preview-original-major-mode - mime-view-content-header-filter-alist)))) - (if (functionp f) - (funcall f) - (mime-view-default-content-header-filter) - )) - (run-hooks 'mime-view-content-header-filter-hook) - ) - (let* ((situation - (ctree-match-calist mime-preview-condition - (list* (cons 'type media-type) - (cons 'subtype media-subtype) - (cons 'encoding encoding) - (cons 'major-mode major-mode) - params))) - (message-button - (cdr (assq 'message-button situation))) - (body-presentation-method - (cdr (assq 'body-presentation-method situation)))) - (when (eq message-button 'visible) - (goto-char (point-max)) - (mime-view-insert-entity-button message-info message-info subj) - ) - (cond ((eq body-presentation-method 'with-filter) - (let ((body-filter (cdr (assq 'body-filter situation)))) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime-raw-buffer end-of-header end) - (funcall body-filter situation) - ))) - ((functionp body-presentation-method) - (funcall body-presentation-method situation) - ) - ((null (mime-entity-children message-info)) - (goto-char (point-max)) - (mime-view-insert-entity-button message-info message-info subj) - )) - (setq ne (point-max)) - (widen) - (put-text-property nb ne 'mime-view-raw-buffer ibuf) - (put-text-property nb ne 'mime-view-entity message-info) - (goto-char ne) - (let ((children (mime-entity-children message-info)) - (default-situation - (cdr (assq 'childrens-situation situation)))) - (while children - (mime-view-display-entity (car children) message-info ibuf obuf - default-situation) - (setq children (cdr children)) - ))))) - (defun mime-view-display-entity (entity message-info ibuf obuf default-situation) (let* ((start (mime-entity-point-min entity)) (end (mime-entity-point-max entity)) - (media-type (mime-entity-media-type entity)) - (media-subtype (mime-entity-media-subtype entity)) - (params (mime-entity-parameters entity)) - (encoding (mime-entity-encoding entity)) + (content-type (mime-entity-content-type entity)) + (encoding (mime-entity-encoding entity)) end-of-header e nb ne subj) (set-buffer ibuf) (goto-char start) @@ -750,24 +742,25 @@ The compressed face will be piped to this command.") ) (save-restriction (narrow-to-region start end) - (setq subj - (eword-decode-string - (mime-raw-get-subject params encoding))) + (setq subj (eword-decode-string (mime-raw-get-subject entity))) ) (let* ((situation - (ctree-match-calist mime-preview-condition - (list* (cons 'type media-type) - (cons 'subtype media-subtype) - (cons 'encoding encoding) - (cons 'major-mode major-mode) - (append params - default-situation)))) + (or + (ctree-match-calist mime-preview-condition + (append + (or content-type + (make-mime-content-type 'text 'plain)) + (list* (cons 'encoding encoding) + (cons 'major-mode major-mode) + default-situation))) + default-situation)) (button-is-invisible (eq (cdr (assq 'entity-button situation)) 'invisible)) (header-is-visible (eq (cdr (assq 'header situation)) 'visible)) (body-presentation-method - (cdr (assq 'body-presentation-method situation)))) + (cdr (assq 'body-presentation-method situation))) + (children (mime-entity-children entity))) (set-buffer obuf) (setq nb (point)) (narrow-to-region nb nb) @@ -794,54 +787,60 @@ The compressed face will be piped to this command.") (insert-buffer-substring mime-raw-buffer end-of-header end) (funcall body-filter situation) ))) + (children) ((functionp body-presentation-method) - (funcall body-presentation-method situation) + (funcall body-presentation-method entity situation) + ) + (t + (when button-is-invisible + (goto-char (point-max)) + (mime-view-insert-entity-button entity message-info subj) + ) + (or header-is-visible + (progn + (goto-char (point-max)) + (insert "\n") + )) )) - (or header-is-visible - body-presentation-method - (progn - (goto-char (point-max)) - (insert "\n") - )) (setq ne (point-max)) (widen) (put-text-property nb ne 'mime-view-raw-buffer ibuf) (put-text-property nb ne 'mime-view-entity entity) (goto-char ne) - (let ((children (mime-entity-children entity)) - (default-situation - (cdr (assq 'childrens-situation situation)))) - (while children - (mime-view-display-entity (car children) message-info ibuf obuf - default-situation) - (setq children (cdr children)) - ))))) - -(defun mime-raw-get-uu-filename (param &optional encoding) - (if (member (or encoding - (cdr (assq 'encoding param)) - ) - mime-view-uuencode-encoding-name-list) - (save-excursion - (or (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - )) - "")) - )) + (if children + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-preview-multipart/mixed entity situation) + )) + ))) + +(defun mime-raw-get-uu-filename () + (save-excursion + (if (re-search-forward "^begin [0-9]+ " nil t) + (if (looking-at ".+$") + (buffer-substring (match-beginning 0)(match-end 0)) + )))) -(defun mime-raw-get-subject (param &optional encoding) +(defun mime-raw-get-subject (entity) (or (std11-find-field-body '("Content-Description" "Subject")) - (let (ret) - (if (or (and (setq ret (mime/Content-Disposition)) - (setq ret (assoc "filename" (cdr ret))) - ) - (setq ret (assoc "name" param)) - (setq ret (assoc "x-name" param)) - ) - (std11-strip-quoted-string (cdr ret)) - )) - (mime-raw-get-uu-filename param encoding) + (let ((ret (mime-entity-content-disposition entity))) + (and ret + (setq ret (mime-content-disposition-filename ret)) + (std11-strip-quoted-string ret) + )) + (let ((ret (mime-entity-content-type entity))) + (and ret + (setq ret + (cdr + (let ((param (mime-content-type-parameters ret))) + (or (assoc "name" param) + (assoc "x-name" param)) + ))) + (std11-strip-quoted-string ret) + )) + (if (member (mime-entity-encoding entity) + mime-view-uuencode-encoding-name-list) + (mime-raw-get-uu-filename)) "")) @@ -1074,8 +1073,7 @@ of the mother-buffer." It calls following-method selected from variable `mime-view-following-method-alist'." (interactive) - (let ((message-info (get-text-property (point-min) 'mime-view-entity)) - entity) + (let (entity) (while (null (setq entity (get-text-property (point) 'mime-view-entity))) (backward-char) @@ -1138,16 +1136,7 @@ It calls following-method selected from variable (erase-buffer) (insert-buffer-substring the-buf p-beg p-end) (goto-char (point-min)) - ;; (if (mime-view-header-visible-p entity message-info) - ;; (delete-region (goto-char (point-min)) - ;; (if (re-search-forward "^$" nil t) - ;; (match-end 0) - ;; (point-min))) - ;; ) - ;;(goto-char (point-min)) - ;;(insert "\n") - (goto-char (point-min)) - (let ((entity-node-id (mime-entity-node-id entity)) ci str) + (let ((entity-node-id (mime-entity-node-id entity)) ci str) (while (progn (setq str @@ -1254,10 +1243,13 @@ variable `mime-view-over-to-previous-method-alist'." (while (null (get-text-property (point) 'mime-view-entity)) (backward-char) ) - (let ((point - (previous-single-property-change (point) 'mime-view-entity))) + (let ((point (previous-single-property-change (point) 'mime-view-entity))) (if point - (goto-char point) + (if (get-text-property (1- point) 'mime-view-entity) + (goto-char point) + (goto-char (1- point)) + (mime-preview-move-to-previous) + ) (let ((f (assq mime-preview-original-major-mode mime-view-over-to-previous-method-alist))) (if f @@ -1270,9 +1262,16 @@ variable `mime-view-over-to-previous-method-alist'." If there is no previous entity, it calls function registered in variable `mime-view-over-to-next-method-alist'." (interactive) + (while (null (get-text-property (point) 'mime-view-entity)) + (forward-char) + ) (let ((point (next-single-property-change (point) 'mime-view-entity))) (if point - (goto-char point) + (progn + (goto-char point) + (if (null (get-text-property point 'mime-view-entity)) + (mime-preview-move-to-next) + )) (let ((f (assq mime-preview-original-major-mode mime-view-over-to-next-method-alist))) (if f @@ -1320,7 +1319,7 @@ If reached to (point-min), it calls function registered in variable (let (point) (save-excursion (catch 'tag - (while (> (point) 1) + (while (not (bobp)) (if (setq point (previous-single-property-change (point) 'mime-view-entity))