X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=4a2ff0fb7133a483458573cafffb4836dfded2ba;hb=3f1499c3761f61a3aa852b73b8110d33a0595f1d;hp=4e05ae2d2d8db8f30de1b45332dc2cdbc5afbe0f;hpb=b5c101682bb576ae78b6fa5f95f6878c16f7a4a6;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index 4e05ae2..4a2ff0f 100644 --- a/mime-view.el +++ b/mime-view.el @@ -3,8 +3,8 @@ ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Created: 1994/7/13 -;; Renamed: 1994/8/31 from tm-body.el +;; Created: 1994/07/13 +;; Renamed: 1994/08/31 from tm-body.el ;; Renamed: 1997/02/19 from tm-view.el ;; Keywords: MIME, multimedia, mail, news @@ -31,16 +31,36 @@ (require 'mel) (require 'eword-decode) (require 'mime-parse) +(require 'semi-def) (require 'calist) +(require 'mailcap) ;;; @ version ;;; (defconst mime-view-version-string - `,(concat "SEMI MIME-View " - (mapconcat #'number-to-string (cdr semi-version) ".") - " (" (car semi-version) ")")) + `,(concat (car mime-module-version) " MIME-View " + (mapconcat #'number-to-string (cddr mime-module-version) ".") + " (" (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 @@ -185,26 +205,22 @@ If optional argument MESSAGE-INFO is not specified, ;;; @@@ predicate function ;;; -(defvar mime-view-content-button-visible-ctype-list - '("application/pgp")) - (defun mime-view-entity-button-visible-p (entity message-info) "Return non-nil if header of ENTITY is visible. Please redefine this function if you want to change default setting." - (and (not (mime-root-entity-p entity)) - (let ((media-type (mime-entity-media-type entity)) - (media-subtype (mime-entity-media-subtype entity))) - (or (not (eq media-type 'application)) - (and (not (eq media-subtype 'x-selection)) - (or (not (eq media-subtype 'octet-stream)) - (let ((mother-entity - (mime-raw-entity-parent entity message-info))) - (or (not (eq (mime-entity-media-type mother-entity) - 'multipart)) - (not (eq (mime-entity-media-subtype mother-entity) - 'encrypted))) - ) - )))))) + (let ((media-type (mime-entity-media-type entity)) + (media-subtype (mime-entity-media-subtype entity))) + (or (not (eq media-type 'application)) + (and (not (eq media-subtype 'x-selection)) + (or (not (eq media-subtype 'octet-stream)) + (let ((mother-entity + (mime-raw-entity-parent entity message-info))) + (or (not (eq (mime-entity-media-type mother-entity) + 'multipart)) + (not (eq (mime-entity-media-subtype mother-entity) + 'encrypted))) + ) + ))))) ;;; @@@ entity button generator ;;; @@ -267,18 +283,17 @@ Please redefine this function if you want to change default setting." ;;; @@@ 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))) - (or (null entity-node-id) - (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) - ))) +;; (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 ;;; @@ -339,6 +354,21 @@ Each elements are regexp of field-name.") ;;; @@@ predicate function ;;; +(defun mime-calist::field-match-method-as-default-rule (calist + field-type field-value) + (let ((s-field (assq field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist) + ) + (t calist)))) + +(define-calist-field-match-method + 'header #'mime-calist::field-match-method-as-default-rule) + +(define-calist-field-match-method + 'body #'mime-calist::field-match-method-as-default-rule) + + (defvar mime-preview-condition nil "Condition-tree about how to display entity.") @@ -377,51 +407,59 @@ Each elements are regexp of field-name.") (ctree-set-calist-strictly 'mime-preview-condition '((body . visible) - (body-filter . mime-view-filter-for-text/plain))) + (body-presentation-method . with-filter) + (body-filter . mime-preview-filter-for-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . nil) (body . visible) - (body-filter . mime-view-filter-for-text/plain))) + (body-presentation-method . with-filter) + (body-filter . mime-preview-filter-for-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . enriched) (body . visible) + (body-presentation-method . with-filter) (body-filter - . mime-view-filter-for-text/enriched))) + . mime-preview-filter-for-text/enriched))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . richtext) (body . visible) + (body-presentation-method . with-filter) (body-filter - . mime-view-filter-for-text/richtext))) + . mime-preview-filter-for-text/richtext))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . t) (body . visible) - (body-filter . mime-view-filter-for-text/plain))) + (body-presentation-method . with-filter) + (body-filter . mime-preview-filter-for-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . message)(subtype . partial) (body-presentation-method . mime-view-insert-message/partial-button))) -(defun mime-view-body-visible-p (entity message-info) - "Return non-nil if body of ENTITY is visible." - (ctree-match-calist mime-preview-condition - (list* (cons 'type (mime-entity-media-type entity)) - (cons 'subtype (mime-entity-media-subtype entity)) - (cons 'encoding (mime-entity-encoding entity)) - (cons 'major-mode major-mode) - (mime-entity-parameters entity)))) +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . rfc822) + (body-presentation-method . nil) + (childrens-situation (header . visible) + (entity-button . invisible)))) + +(ctree-set-calist-strictly + 'mime-preview-condition '((type . message)(subtype . news) + (body-presentation-method . nil) + (childrens-situation (header . visible) + (entity-button . invisible)))) ;;; @@@ entity filter ;;; -(autoload 'mime-view-filter-for-text/plain "mime-text") -(autoload 'mime-view-filter-for-text/enriched "mime-text") -(autoload 'mime-view-filter-for-text/richtext "mime-text") +(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) @@ -464,77 +502,133 @@ if it is not nil.") )) -;;; @@ entity separator +;;; @ acting-condition ;;; -(defun mime-view-entity-separator-visible-p (entity message-info) - "Return non-nil if separator is needed for ENTITY." - (and (not (mime-view-header-visible-p entity message-info)) - (not (mime-view-body-visible-p entity message-info)))) +(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-strictly + 'mime-acting-condition + (append shared (list '(mode . "play")(cons 'method (cdr view))))) + (if print + (ctree-set-calist-strictly + '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) +;; )) -;;; @ acting-condition -;;; +(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) + )) -(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")) - )) +(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 @@ -618,11 +712,9 @@ The compressed face will be piped to this command.") (or mime-view-redisplay (setq mime-raw-message-info (mime-parse-message ctl encoding)) ) - (let* ((message-info mime-raw-message-info) - (pcl (mime-raw-flatten-message-info message-info)) - (the-buf (current-buffer)) - (mode major-mode) - ) + (let ((message-info mime-raw-message-info) + (the-buf (current-buffer)) + (mode major-mode)) (or obuf (setq obuf (concat "*Preview-" (buffer-name the-buf) "*"))) (set-buffer (get-buffer-create obuf)) @@ -634,10 +726,7 @@ 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") - (while pcl - (mime-view-display-entity (car pcl) message-info the-buf obuf) - (setq pcl (cdr pcl)) - ) + (mime-view-display-message message-info the-buf obuf) (set-buffer-modified-p nil) ) (setq buffer-read-only t) @@ -646,20 +735,13 @@ The compressed face will be piped to this command.") (setq mime-preview-buffer obuf) ) -(defun mime-view-display-entity (entity message-info ibuf obuf) - "Display ENTITY." - (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)) - (ctype (if media-type - (if media-subtype - (format "%s/%s" media-type media-subtype) - (symbol-name media-type) - ))) - (params (mime-entity-parameters entity)) - (encoding (mime-entity-encoding entity)) - (entity-node-id (mime-entity-node-id entity)) +(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) @@ -678,28 +760,18 @@ The compressed face will be piped to this command.") (set-buffer obuf) (setq nb (point)) (narrow-to-region nb nb) - (if (mime-view-entity-button-visible-p entity message-info) - (mime-view-insert-entity-button entity message-info subj) - ) - (if (mime-view-header-visible-p entity message-info) - (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) - )) - (if (and (mime-root-entity-p entity) - (member - ctype mime-view-content-button-visible-ctype-list)) - (save-excursion - (goto-char (point-max)) - (mime-view-insert-entity-button entity message-info subj) + ;; 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) @@ -707,33 +779,127 @@ The compressed face will be piped to this command.") (cons 'encoding encoding) (cons 'major-mode major-mode) params))) - (body-filter (cdr (assq 'body-filter situation))) - (body-presentation-method + (message-button + (cdr (assq 'message-button situation))) + (body-presentation-method (cdr (assq 'body-presentation-method situation)))) - (cond ((functionp body-filter) - (save-restriction - (narrow-to-region (point-max)(point-max)) - (insert-buffer-substring mime-raw-buffer end-of-header end) - (funcall body-filter ctype params encoding) - )) + (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) ) - ((and (null entity-node-id) - (null (mime-entity-children message-info))) + ((null (mime-entity-children message-info)) (goto-char (point-max)) - (mime-view-insert-entity-button entity message-info subj) + (mime-view-insert-entity-button message-info message-info subj) )) - (when (mime-view-entity-separator-visible-p entity message-info) - (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 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)) + 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) ) - (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) - )) + (save-restriction + (narrow-to-region start end) + (setq subj + (eword-decode-string + (mime-raw-get-subject params encoding))) + ) + (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)))) + (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)))) + (set-buffer obuf) + (setq nb (point)) + (narrow-to-region nb nb) + (or button-is-invisible + (if (mime-view-entity-button-visible-p entity message-info) + (mime-view-insert-entity-button entity message-info subj) + )) + (if header-is-visible + (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) + )) + (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) + )) + (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 @@ -992,8 +1158,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) @@ -1056,16 +1221,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