X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fsemi.git;a=blobdiff_plain;f=mime-view.el;h=66c8a7b7c62a8f7f264bb6276f3178b453b454cb;hp=bd68ffa75d58e974e75655c6905d3d0b3cd783b8;hb=HEAD;hpb=1c61d6b2022fc26bcc84276f883c8e523df9d400 diff --git a/mime-view.el b/mime-view.el index bd68ffa..66c8a7b 100644 --- a/mime-view.el +++ b/mime-view.el @@ -1,14 +1,14 @@ ;;; mime-view.el --- interactive MIME viewer for GNU Emacs -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1995,96,97,98,99,2000 Free Software Foundation, Inc. -;; Author: MORIOKA Tomohiko +;; Author: MORIOKA Tomohiko ;; 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 -;; This file is part of SEMI (Sophisticated Emacs MIME Interfaces). +;; This file is part of SEMI (Sample of Elastic MIME Interfaces). ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -22,61 +22,86 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Code: -(require 'std11) -(require 'mel) -(require 'eword-decode) -(require 'mime-parse) +(require 'mime) (require 'semi-def) (require 'calist) +(require 'alist) +(require 'mime-conf) + +(eval-when-compile (require 'static)) ;;; @ version ;;; -(defconst mime-view-version-string - `,(concat (car mime-module-version) " MIME-View " - (mapconcat #'number-to-string (cddr mime-module-version) ".") - " (" (cadr mime-module-version) ")")) +(defconst mime-view-version + (concat (mime-product-name mime-user-interface-product) " MIME-View " + (mapconcat #'number-to-string + (mime-product-version mime-user-interface-product) ".") + " (" (mime-product-code-name mime-user-interface-product) ")")) -;;; @ buffer local variables +;;; @ variables ;;; -;;; @@ in raw-buffer +(defgroup mime-view nil + "MIME view mode" + :group 'mime) + +(defcustom mime-situation-examples-file "~/.mime-example" + "*File name of situation-examples demonstrated by user." + :group 'mime-view + :type 'file) + +(defcustom mime-preview-move-scroll nil + "*Decides whether to scroll when moving to next entity. +When t, scroll the buffer. Non-nil but not t means scroll when +the next entity is within next-screen-context-lines from top or +buttom. Nil means don't scroll at all." + :group 'mime-view + :type '(choice (const :tag "Off" nil) + (const :tag "On" t) + (sexp :tag "Situation" 1))) + +(defcustom mime-view-mailcap-files + (let ((files '("/etc/mailcap" "/usr/etc/mailcap" "~/.mailcap"))) + (or (member mime-mailcap-file files) + (setq files (cons mime-mailcap-file files))) + files) + "List of mailcap files." + :group 'mime-view + :type '(repeat file)) + +(defcustom mime-view-buttons-visible t + "Toggle visibility of MIME buttons." + :group 'mime-view + :type 'boolean) + +;;; @ in raw-buffer (representation space) ;;; -(defvar mime-raw-message-info - "Information about structure of message. -Please use reference function `mime-entity-SLOT' to get value of SLOT. - -Following is a list of slots of the structure: - -node-id reversed entity-number (list of integers) -point-min beginning point of region in raw-buffer -point-max end point of region in raw-buffer -type media-type (symbol) -subtype media-subtype (symbol) -type/subtype media-type/subtype (string or nil) -parameters parameter of Content-Type field (association list) -encoding Content-Transfer-Encoding (string or nil) -children entities included in this entity (list of content-infos) - -If an entity includes other entities in its body, such as multipart or -message/rfc822, `mime-entity' structures of them are included in -`children', so the `mime-entity' structure become a tree.") -(make-variable-buffer-local 'mime-raw-message-info) - (defvar mime-preview-buffer nil "MIME-preview buffer corresponding with the (raw) buffer.") (make-variable-buffer-local 'mime-preview-buffer) -;;; @@ in 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'.") + + +;;; @ in preview-buffer (presentation space) ;;; (defvar mime-mother-buffer nil @@ -85,96 +110,436 @@ If current MIME-preview buffer is generated by other buffer, such as message/partial, it is called `mother-buffer'.") (make-variable-buffer-local 'mime-mother-buffer) -(defvar mime-raw-buffer nil - "Raw buffer corresponding with the (MIME-preview) buffer.") -(make-variable-buffer-local 'mime-raw-buffer) - -(defvar mime-preview-original-major-mode nil - "Major-mode of mime-raw-buffer.") -(make-variable-buffer-local 'mime-preview-original-major-mode) +;; (defvar mime-raw-buffer nil +;; "Raw buffer corresponding with the (MIME-preview) buffer.") +;; (make-variable-buffer-local 'mime-raw-buffer) (defvar mime-preview-original-window-configuration nil "Window-configuration before mime-view-mode is called.") (make-variable-buffer-local 'mime-preview-original-window-configuration) +(defun mime-preview-original-major-mode (&optional recursive point) + "Return major-mode of original buffer. +If optional argument RECURSIVE is non-nil and current buffer has +mime-mother-buffer, it returns original major-mode of the +mother-buffer." + (if (and recursive mime-mother-buffer) + (save-excursion + (set-buffer mime-mother-buffer) + (mime-preview-original-major-mode recursive) + ) + (cdr (assq 'major-mode + (get-text-property (or point + (if (> (point) (buffer-size)) + (max (1- (point-max)) (point-min)) + (point))) + 'mime-view-situation))))) + ;;; @ entity information ;;; -(defsubst mime-raw-find-entity-from-node-id (entity-node-id - &optional message-info) - "Return entity from ENTITY-NODE-ID in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-raw-find-entity-from-number (reverse entity-node-id) message-info)) - -(defun mime-raw-find-entity-from-number (entity-number &optional message-info) - "Return entity from ENTITY-NUMBER in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (if (eq entity-number t) - message-info - (let ((sn (car entity-number))) - (if (null sn) - message-info - (let ((rc (nth sn (mime-entity-children message-info)))) - (if rc - (mime-raw-find-entity-from-number (cdr entity-number) rc) +(defun mime-entity-situation (entity &optional situation) + "Return situation of ENTITY." + (let (rest param name) + ;; Content-Type + (unless (assq 'type situation) + (setq rest (or (mime-entity-content-type entity) + (make-mime-content-type 'text 'plain)) + situation (cons (car rest) situation) + rest (cdr rest)) + ) + (unless (assq 'subtype situation) + (or rest + (setq rest (or (cdr (mime-entity-content-type entity)) + '((subtype . plain))))) + (setq situation (cons (car rest) situation) + rest (cdr rest)) + ) + (while rest + (setq param (car rest)) + (or (assoc (car param) situation) + (setq situation (cons param situation))) + (setq rest (cdr rest))) + + ;; Content-Disposition + (setq rest nil) + (unless (assq 'disposition-type situation) + (setq rest (mime-entity-content-disposition entity)) + (if rest + (setq situation (cons (cons 'disposition-type + (mime-content-disposition-type rest)) + situation) + rest (mime-content-disposition-parameters rest)) + )) + (while rest + (setq param (car rest) + name (car param)) + (if (cond ((string= name "filename") + (if (assq 'filename situation) + nil + (setq name 'filename))) + ((string= name "creation-date") + (if (assq 'creation-date situation) + nil + (setq name 'creation-date))) + ((string= name "modification-date") + (if (assq 'modification-date situation) + nil + (setq name 'modification-date))) + ((string= name "read-date") + (if (assq 'read-date situation) + nil + (setq name 'read-date))) + ((string= name "size") + (if (assq 'size situation) + nil + (setq name 'size))) + (t (setq name (cons 'disposition name)) + (if (assoc name situation) + nil + name))) + (setq situation + (cons (cons name (cdr param)) + situation))) + (setq rest (cdr rest))) + + ;; Content-Transfer-Encoding + (or (assq 'encoding situation) + (setq situation + (cons (cons 'encoding (or (mime-entity-encoding entity) + "7bit")) + situation))) + + situation)) + +(defsubst mime-delq-null-situation (situations field + &rest ignored-values) + (let (dest) + (while situations + (let* ((situation (car situations)) + (cell (assq field situation))) + (if cell + (or (memq (cdr cell) ignored-values) + (setq dest (cons situation dest)) + ))) + (setq situations (cdr situations))) + dest)) + +(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-find-entity-from-point (point &optional message-info) - "Return entity from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (if (and (<= (mime-entity-point-min message-info) point) - (<= point (mime-entity-point-max message-info))) - (let ((children (mime-entity-children message-info))) - (catch 'tag - (while children - (let ((ret - (mime-raw-find-entity-from-point point (car children)))) - (if ret - (throw 'tag ret) - )) - (setq children (cdr children))) - message-info)))) - -(defsubst mime-raw-point-to-entity-node-id (point &optional message-info) - "Return entity-node-id from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-entity-node-id (mime-raw-find-entity-from-point point message-info))) - -(defsubst mime-raw-point-to-entity-number (point &optional message-info) - "Return entity-number from POINT in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (reverse (mime-raw-point-to-entity-node-id point message-info))) - -(defsubst mime-raw-entity-parent (entity &optional message-info) - "Return mother entity of ENTITY. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (mime-raw-find-entity-from-node-id (cdr (mime-entity-node-id entity)) - message-info)) - -(defun mime-raw-flatten-message-info (&optional message-info) - "Return list of entity in mime-raw-buffer. -If optional argument MESSAGE-INFO is not specified, -`mime-raw-message-info' is used." - (or message-info - (setq message-info mime-raw-message-info)) - (let ((dest (list message-info)) - (rcl (mime-entity-children message-info))) - (while rcl - (setq dest (nconc dest (mime-raw-flatten-message-info (car rcl)))) - (setq rcl (cdr rcl))) - dest)) +(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)) + ))) + ) + +(defun mime-unify-situations (entity-situation + condition situation-examples + &optional required-name ignored-value + every-situations) + (let (ret) + (in-calist-package 'mime-view) + (setq ret + (ctree-find-calist condition entity-situation + every-situations)) + (if required-name + (setq ret (mime-delq-null-situation ret required-name + ignored-value t))) + (or (assq 'ignore-examples entity-situation) + (if (cdr ret) + (let ((rest ret) + (max-score 0) + (max-escore 0) + max-examples + max-situations) + (while rest + (let ((situation (car rest)) + (examples situation-examples)) + (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 situation-examples))) + (if cell + (setcdr cell (1+ (cdr cell))) + (setq situation-examples + (cons (cons example 0) + situation-examples)) + )) + (setq max-examples (cdr max-examples)) + ))))) + (cons ret situation-examples) + ;; ret: list of situations + ;; situation-examples: new examples (notoce that contents of + ;; argument `situation-examples' has bees modified) + )) + +(defun mime-view-entity-title (entity) + (or (mime-entity-read-field entity 'Content-Description) + (mime-entity-read-field entity 'Subject) + (mime-entity-filename entity) + "")) + +(defvar mime-preview-situation-example-list nil) +(defvar mime-preview-situation-example-list-max-size 16) +;; (defvar mime-preview-situation-example-condition nil) + +(defun mime-find-entity-preview-situation (entity + &optional default-situation) + (or (let ((ret + (mime-unify-situations + (append (mime-entity-situation entity) + default-situation) + mime-preview-condition + mime-preview-situation-example-list))) + (setq mime-preview-situation-example-list + (cdr ret)) + (caar ret)) + default-situation)) + + +(defvar mime-acting-situation-example-list nil) +(defvar mime-acting-situation-example-list-max-size 16) +(defvar mime-situation-examples-file-coding-system nil) + +(defun mime-view-read-situation-examples-file (&optional file) + (or file + (setq file mime-situation-examples-file)) + (if (and file + (file-readable-p file)) + (with-temp-buffer + (insert-file-contents file) + (setq mime-situation-examples-file-coding-system + (static-cond + ((boundp 'buffer-file-coding-system) + (symbol-value 'buffer-file-coding-system)) + ((boundp 'file-coding-system) + (symbol-value 'file-coding-system)) + (t nil)) + ;; (and (boundp 'buffer-file-coding-system) + ;; buffer-file-coding-system) + ) + (condition-case error + (eval-buffer) + (error (message "%s is broken: %s" file (cdr error)))) + ;; format check + (condition-case nil + (let ((i 0)) + (while (and (> (length mime-preview-situation-example-list) + mime-preview-situation-example-list-max-size) + (< i 16)) + (setq mime-preview-situation-example-list + (mime-reduce-situation-examples + mime-preview-situation-example-list)) + (setq i (1+ i)))) + (error (setq mime-preview-situation-example-list nil))) + ;; (let ((rest mime-preview-situation-example-list)) + ;; (while rest + ;; (ctree-set-calist-strictly 'mime-preview-condition + ;; (caar rest)) + ;; (setq rest (cdr rest)))) + (condition-case nil + (let ((i 0)) + (while (and (> (length mime-acting-situation-example-list) + mime-acting-situation-example-list-max-size) + (< i 16)) + (setq mime-acting-situation-example-list + (mime-reduce-situation-examples + mime-acting-situation-example-list)) + (setq i (1+ i)))) + (error (setq mime-acting-situation-example-list nil)))))) + +(defun mime-save-situation-examples () + (if (or mime-preview-situation-example-list + mime-acting-situation-example-list) + (let ((file mime-situation-examples-file) + print-length print-level) + (when file + (with-temp-buffer + (insert ";;; " (file-name-nondirectory file) "\n") + (insert "\n;; This file is generated automatically by " + mime-view-version "\n\n") + (insert ";;; Code:\n\n") + (if mime-preview-situation-example-list + (pp `(setq mime-preview-situation-example-list + ',mime-preview-situation-example-list) + (current-buffer))) + (if mime-acting-situation-example-list + (pp `(setq mime-acting-situation-example-list + ',mime-acting-situation-example-list) + (current-buffer))) + (insert "\n;;; " + (file-name-nondirectory file) + " ends here.\n") + (static-cond + ((boundp 'buffer-file-coding-system) + (setq buffer-file-coding-system + mime-situation-examples-file-coding-system)) + ((boundp 'file-coding-system) + (setq file-coding-system + mime-situation-examples-file-coding-system))) + ;; (setq buffer-file-coding-system + ;; mime-situation-examples-file-coding-system) + (setq buffer-file-name file) + (save-buffer)))))) + +(add-hook 'kill-emacs-hook 'mime-save-situation-examples) + +(defun mime-reduce-situation-examples (situation-examples) + (let ((len (length situation-examples)) + i ir ic j jr jc ret + dest d-i d-j + (max-sim 0) sim + min-det-ret det-ret + min-det-org det-org + min-freq freq) + (setq i 0 + ir situation-examples) + (while (< i len) + (setq ic (car ir) + j 0 + jr situation-examples) + (while (< j len) + (unless (= i j) + (setq jc (car jr)) + (setq ret (mime-compare-situation-with-example (car ic)(car jc)) + sim (car ret) + det-ret (+ (length (car ic))(length (car jc))) + det-org (length (cdr ret)) + freq (+ (cdr ic)(cdr jc))) + (cond ((< max-sim sim) + (setq max-sim sim + min-det-ret det-ret + min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= max-sim sim) + (cond ((> min-det-ret det-ret) + (setq min-det-ret det-ret + min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= min-det-ret det-ret) + (cond ((> min-det-org det-org) + (setq min-det-org det-org + min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + ) + ((= min-det-org det-org) + (cond ((> min-freq freq) + (setq min-freq freq + d-i i + d-j j + dest (cons (cdr ret) freq)) + )) + )) + )) + )) + ) + (setq jr (cdr jr) + j (1+ j))) + (setq ir (cdr ir) + i (1+ i))) + (if (> d-i d-j) + (setq i d-i + d-i d-j + d-j i)) + (setq jr (nthcdr (1- d-j) situation-examples)) + (setcdr jr (cddr jr)) + (if (= d-i 0) + (setq situation-examples + (cdr situation-examples)) + (setq ir (nthcdr (1- d-i) situation-examples)) + (setcdr ir (cddr ir)) + ) + (if (setq ir (assoc (car dest) situation-examples)) + (progn + (setcdr ir (+ (cdr ir)(cdr dest))) + situation-examples) + (cons dest situation-examples) + ;; situation-examples may be modified. + ))) ;;; @ presentation of preview @@ -186,30 +551,30 @@ If optional argument MESSAGE-INFO is not specified, ;;; @@@ predicate function ;;; -(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." - (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))) - ) - ))))) +;; (defun mime-view-entity-button-visible-p (entity) +;; "Return non-nil if header of ENTITY is visible. +;; Please redefine this function if you want to change default setting." +;; (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-entity-parent entity))) +;; (or (not (eq (mime-entity-media-type mother-entity) +;; 'multipart)) +;; (not (eq (mime-entity-media-subtype mother-entity) +;; 'encrypted))) +;; ) +;; ))))) ;;; @@@ entity button generator ;;; -(defun mime-view-insert-entity-button (entity message-info subj) +(defun mime-view-insert-entity-button (entity) "Insert entity-button of ENTITY." (let ((entity-node-id (mime-entity-node-id entity)) - (params (mime-entity-parameters entity))) + (params (mime-entity-parameters entity)) + (subject (mime-view-entity-title entity))) (mime-insert-button (let ((access-type (assoc "access-type" params)) (num (or (cdr (assoc "x-part-number" params)) @@ -226,33 +591,35 @@ Please redefine this function if you want to change default setting." (setq access-type (cdr access-type)) (if server (format "%s %s ([%s] %s)" - num subj access-type (cdr server)) + num subject access-type (cdr server)) (let ((site (cdr (assoc "site" params))) (dir (cdr (assoc "directory" params))) + (url (cdr (assoc "url" params))) ) - (format "%s %s ([%s] %s:%s)" - num subj access-type site dir) + (if url + (format "%s %s ([%s] %s)" + num subject access-type url) + (format "%s %s ([%s] %s:%s)" + num subject access-type site dir)) ))) ) (t - (let ((media-type (mime-entity-media-type entity)) - (media-subtype (mime-entity-media-subtype entity)) - (charset (cdr (assoc "charset" params))) - (encoding (mime-entity-encoding entity))) + (let* ((charset (cdr (assoc "charset" params))) + (encoding (mime-entity-encoding entity)) + (rest (format " <%s/%s%s%s>" + (mime-entity-media-type entity) + (mime-entity-media-subtype entity) + (if charset + (concat "; " charset) + "") + (if encoding + (concat " (" encoding ")") + "")))) (concat - num " " subj - (let ((rest - (format " <%s/%s%s%s>" - media-type media-subtype - (if charset - (concat "; " charset) - "") - (if encoding - (concat " (" encoding ")") - "")))) - (if (>= (+ (current-column)(length rest))(window-width)) - "\n\t") - rest))) + num " " subject + (if (>= (+ (current-column)(length rest))(window-width)) + "\n\t") + rest)) ))) (function mime-preview-play-current-entity)) )) @@ -261,73 +628,25 @@ 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 -;;; - -(defvar mime-view-content-header-filter-alist nil) - -(defun mime-view-default-content-header-filter () - (mime-view-cut-header) - (eword-decode-header) - ) - -;;; @@@ entity field cutter -;;; +(defvar mime-header-presentation-method-alist nil + "Alist of major mode vs. corresponding header-presentation-method functions. +Each element looks like (SYMBOL . FUNCTION). +SYMBOL must be major mode in raw-buffer or t. t means default. +Interface of FUNCTION must be (ENTITY SITUATION).") (defvar mime-view-ignored-field-list - '(".*Received" ".*Path" ".*Id" "References" - "Replied" "Errors-To" - "Lines" "Sender" ".*Host" "Xref" - "Content-Type" "Precedence" - "Status" "X-VM-.*") + '(".*Received:" ".*Path:" ".*Id:" "^References:" + "^Replied:" "^Errors-To:" + "^Lines:" "^Sender:" ".*Host:" "^Xref:" + "^Content-Type:" "^Precedence:" + "^Status:" "^X-VM-.*:") "All fields that match this list will be hidden in MIME preview buffer. Each elements are regexp of field-name.") -(defvar mime-view-ignored-field-regexp - (concat "^" - (apply (function regexp-or) mime-view-ignored-field-list) - ":")) - -(defvar mime-view-visible-field-list '("Dnas.*" "Message-Id") +(defvar mime-view-visible-field-list '("^Dnas.*:" "^Message-Id:") "All fields that match this list will be displayed in MIME preview buffer. Each elements are regexp of field-name.") -(defun mime-view-cut-header () - (goto-char (point-min)) - (while (re-search-forward mime-view-ignored-field-regexp nil t) - (let* ((beg (match-beginning 0)) - (end (match-end 0)) - (name (buffer-substring beg end)) - ) - (catch 'visible - (let ((rest mime-view-visible-field-list)) - (while rest - (if (string-match (car rest) name) - (throw 'visible nil) - ) - (setq rest (cdr rest)))) - (delete-region beg - (save-excursion - (if (re-search-forward "^\\([^ \t]\\|$\\)" nil t) - (match-beginning 0) - (point-max)))) - )))) - ;;; @@ entity-body ;;; @@ -335,6 +654,8 @@ Each elements are regexp of field-name.") ;;; @@@ predicate function ;;; +(in-calist-package 'mime-view) + (defun mime-calist::field-match-method-as-default-rule (calist field-type field-value) (let ((s-field (assq field-type calist))) @@ -349,6 +670,19 @@ Each elements are regexp of field-name.") (define-calist-field-match-method 'body #'mime-calist::field-match-method-as-default-rule) +(defun mime-calist::field-match-method-ignore-case (calist + field-type field-value) + (let ((s-field (assoc field-type calist))) + (cond ((null s-field) + (cons (cons field-type field-value) calist)) + ((eq field-value t) + calist) + ((string= (downcase (cdr s-field)) (downcase field-value)) + calist)))) + +(define-calist-field-match-method + 'access-type #'mime-calist::field-match-method-ignore-case) + (defvar mime-preview-condition nil "Condition-tree about how to display entity.") @@ -387,75 +721,122 @@ 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-display-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-display-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-display-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-display-text/richtext))) + +(autoload 'mime-display-application/x-postpet "postpet") (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 . application)(subtype . x-postpet) + (body . visible) + (body-presentation-method . mime-display-application/x-postpet))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . message)(subtype . partial) - (body-presentation-method - . mime-view-insert-message/partial-button))) + 'mime-preview-condition + '((type . text)(subtype . t) + (body . visible) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . message)(subtype . rfc822) - (body-presentation-method . nil) - (childrens-situation (header . visible) - (entity-button . invisible)))) + 'mime-preview-condition + '((type . multipart)(subtype . alternative) + (body . visible) + (body-presentation-method . mime-display-multipart/alternative))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . message)(subtype . news) - (body-presentation-method . nil) - (childrens-situation (header . visible) - (entity-button . invisible)))) + 'mime-preview-condition + '((type . multipart)(subtype . related) + (body . visible) + (body-presentation-method . mime-display-multipart/related))) +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . multipart)(subtype . t) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed))) -;;; @@@ entity filter -;;; +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . partial) + (body . visible) + (body-presentation-method . mime-display-message/partial-button))) -(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") +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . rfc822) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed) + (childrens-situation (header . visible) + (entity-button . invisible)))) -(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. +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . news) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed) + (childrens-situation (header . visible) + (entity-button . invisible)))) -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.") +;;; @@@ entity presentation +;;; + +(defun mime-display-text/plain (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (condition-case nil + (mime-insert-text-content entity) + (error (progn + (message "Can't decode current entity.") + (sit-for 1)))) + (run-hooks 'mime-text-decode-hook) + (goto-char (point-max)) + (if (not (eq (char-after (1- (point))) ?\n)) + (insert "\n") + ) + (mime-add-url-buttons) + (run-hooks 'mime-display-text/plain-hook) + )) + +(defun mime-display-text/richtext (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (richtext-decode beg (point-max)) + ))) + +(defun mime-display-text/enriched (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (run-hooks 'mime-text-decode-hook) + (let ((beg (point-min))) + (remove-text-properties beg (point-max) '(face nil)) + (enriched-decode beg (point-max)) + ))) (defvar mime-view-announcement-for-message/partial @@ -469,7 +850,7 @@ if it is not nil.") \[[ Please press `v' key in this buffer. ]]" )) -(defun mime-view-insert-message/partial-button (&optional situation) +(defun mime-display-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) @@ -482,6 +863,105 @@ if it is not nil.") #'mime-preview-play-current-entity) )) +(defun mime-display-multipart/mixed (entity situation) + (let ((children (mime-entity-children entity)) + (original-major-mode-cell (assq 'major-mode situation)) + (default-situation + (cdr (assq 'childrens-situation situation)))) + (if original-major-mode-cell + (setq default-situation + (cons original-major-mode-cell default-situation))) + (while children + (mime-display-entity (car children) nil default-situation) + (setq children (cdr children)) + ))) + +(defcustom mime-view-type-subtype-score-alist + '(((text . enriched) . 3) + ((text . richtext) . 2) + ((text . plain) . 1) + (t . 0)) + "Alist MEDIA-TYPE vs corresponding score. +MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." + :group 'mime-view + :type '(repeat (cons (choice :tag "Media-Type" + (cons :tag "Type/Subtype" + (symbol :tag "Primary-type") + (symbol :tag "Subtype")) + (symbol :tag "Type") + (const :tag "Default" t)) + integer))) + +(defun mime-display-multipart/alternative (entity situation) + (let* ((children (mime-entity-children entity)) + (original-major-mode-cell (assq 'major-mode situation)) + (default-situation + (cdr (assq 'childrens-situation situation))) + (i 0) + (p 0) + (max-score 0) + situations) + (if original-major-mode-cell + (setq default-situation + (cons original-major-mode-cell default-situation))) + (setq situations + (mapcar (function + (lambda (child) + (let ((situation + (mime-find-entity-preview-situation + child default-situation))) + (if (cdr (assq 'body-presentation-method situation)) + (let ((score + (cdr + (or (assoc + (cons + (cdr (assq 'type situation)) + (cdr (assq 'subtype situation))) + mime-view-type-subtype-score-alist) + (assq + (cdr (assq 'type situation)) + mime-view-type-subtype-score-alist) + (assq + t + mime-view-type-subtype-score-alist) + )))) + (if (> score max-score) + (setq p i + max-score score) + ))) + (setq i (1+ i)) + situation) + )) + children)) + (setq i 0) + (while children + (let ((child (car children)) + (situation (car situations))) + (mime-display-entity child (if (= i p) + situation + (put-alist 'body 'invisible + (copy-alist situation))))) + (setq children (cdr children) + situations (cdr situations) + i (1+ i))))) + +(defun mime-display-multipart/related (entity situation) + (let* ((param-start (mime-parse-msg-id + (std11-lexical-analyze + (cdr (assoc "start" + (mime-content-type-parameters + (mime-entity-content-type entity))))))) + (start (or (and param-start (mime-find-entity-from-content-id + param-start + entity)) + (car (mime-entity-children entity)))) + (original-major-mode-cell (assq 'major-mode situation)) + (default-situation (cdr (assq 'childrens-situation situation)))) + (when start + (if original-major-mode-cell + (setq default-situation + (cons original-major-mode-cell default-situation))) + (mime-display-entity start nil default-situation)))) ;;; @ acting-condition ;;; @@ -489,98 +969,92 @@ if it is not nil.") (defvar mime-acting-condition nil "Condition-tree about how to process entity.") -(ctree-set-calist-strictly - 'mime-acting-condition - '((type . t)(subtype . t)(mode . "play") - (method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file) - )) -(ctree-set-calist-strictly - 'mime-acting-condition - '((type . t)(subtype . t)(mode . "extract") - (method . mime-method-to-save))) +(defun mime-view-read-mailcap-files (&optional files) + (or files + (setq files mime-view-mailcap-files)) + (let (entries file) + (while files + (setq file (car files)) + (if (file-readable-p file) + (setq entries (append entries (mime-parse-mailcap-file file)))) + (setq files (cdr files))) + (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))))) + +(mime-view-read-mailcap-files) (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) + '((type . application)(subtype . octet-stream) + (mode . "play") + (method . mime-detect-content) )) -(ctree-set-calist-strictly +(ctree-set-calist-with-default 'mime-acting-condition - '((type . audio)(subtype . basic)(mode . "play") - (method "tm-au" nil 'file "" 'encoding 'mode 'name) - )) + '((mode . "extract") + (method . mime-save-content))) (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) + '((type . text)(subtype . x-rot13-47)(mode . "play") + (method . mime-view-caesar) )) - (ctree-set-calist-strictly 'mime-acting-condition - '((type . video)(subtype . mpeg)(mode . "play") - (method "tm-mpeg" nil 'file "" 'encoding 'mode 'name) + '((type . text)(subtype . x-rot13-47-48)(mode . "play") + (method . mime-view-caesar) )) (ctree-set-calist-strictly 'mime-acting-condition - '((type . application)(subtype . postscript)(mode . "play") - (method "tm-ps" nil 'file "" 'encoding 'mode 'name) + '((type . message)(subtype . rfc822)(mode . "play") + (method . mime-view-message/rfc822) )) (ctree-set-calist-strictly 'mime-acting-condition - '((type . application)(subtype . postscript)(mode . "print") - (method "tm-ps" nil 'file "" 'encoding 'mode 'name) + '((type . message)(subtype . partial)(mode . "play") + (method . mime-store-message/partial-piece) )) (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) + '((type . message)(subtype . external-body) + ("access-type" . "anon-ftp") + (method . mime-view-message/external-anon-ftp) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . external-body) - ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) + ("access-type" . "url") + (method . mime-view-message/external-url) )) (ctree-set-calist-strictly 'mime-acting-condition '((type . application)(subtype . octet-stream) - (method . mime-method-to-save) + (method . mime-save-content) )) @@ -592,294 +1066,97 @@ if it is not nil.") . mime-preview-quitting-method-for-mime-show-message-mode)) "Alist of major-mode vs. quitting-method of mime-view.") -(defvar mime-view-over-to-previous-method-alist nil) -(defvar mime-view-over-to-next-method-alist nil) +(defvar mime-preview-over-to-previous-method-alist nil + "Alist of major-mode vs. over-to-previous-method of mime-view.") -(defvar mime-view-show-summary-method nil - "Alist of major-mode vs. show-summary-method.") +(defvar mime-preview-over-to-next-method-alist nil + "Alist of major-mode vs. over-to-next-method of mime-view.") ;;; @ following method ;;; -(defvar mime-view-following-method-alist nil +(defvar mime-preview-following-method-alist nil "Alist of major-mode vs. following-method of mime-view.") (defvar mime-view-following-required-fields-list '("From")) -;;; @ X-Face -;;; - -;; hack from Gnus 5.0.4. - -(defvar mime-view-x-face-to-pbm-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm") - -(defvar mime-view-x-face-command - (concat mime-view-x-face-to-pbm-command - " | xv -quit -") - "String to be executed to display an X-Face field. -The command will be executed in a sub-shell asynchronously. -The compressed face will be piped to this command.") - -(defun mime-view-x-face-function () - "Function to display X-Face field. You can redefine to customize." - ;; 1995/10/12 (c.f. tm-eng:130) - ;; fixed by Eric Ding - (save-restriction - (narrow-to-region (point-min) (re-search-forward "^$" nil t)) - ;; end - (goto-char (point-min)) - (if (re-search-forward "^X-Face:[ \t]*" nil t) - (let ((beg (match-end 0)) - (end (std11-field-end)) - ) - (call-process-region beg end "sh" nil 0 nil - "-c" mime-view-x-face-command) - )))) - - -;;; @ miscellaneous -;;; - -(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 ;;; -(defvar mime-view-redisplay nil) - -(defun mime-view-setup-buffers (&optional ctl encoding ibuf obuf) - (if ibuf - (progn - (get-buffer ibuf) - (set-buffer ibuf) - )) - (or mime-view-redisplay - (setq mime-raw-message-info (mime-parse-message ctl encoding)) - ) - (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)) - (let ((inhibit-read-only t)) - ;;(setq buffer-read-only nil) - (widen) - (erase-buffer) - (setq mime-raw-buffer the-buf) - (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) - (set-buffer-modified-p nil) - ) - (setq buffer-read-only t) - (set-buffer the-buf) - ) - (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)) - 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))) - ) - (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) +(defun mime-display-entity (entity &optional situation + default-situation preview-buffer) + (or preview-buffer + (setq preview-buffer (current-buffer))) + (let* (e nb ne nhb nbb) + (in-calist-package 'mime-view) + (or situation + (setq situation + (mime-find-entity-preview-situation entity default-situation))) + (let ((button-is-invisible + (or (not mime-view-buttons-visible) + (eq (cdr (or (assq '*entity-button situation) + (assq 'entity-button situation))) + 'invisible))) + (header-is-visible + (eq (cdr (or (assq '*header situation) + (assq 'header situation))) + 'visible)) + (body-is-visible + (eq (cdr (or (assq '*body situation) + (assq 'body situation))) + 'visible)) + (children (mime-entity-children entity))) + (set-buffer preview-buffer) (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 (mime-view-entity-button-visible-p entity) + (mime-view-insert-entity-button entity) + ;; ) + ) (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 + (let ((header-presentation-method + (or (cdr (assq 'header-presentation-method situation)) + (cdr (assq (cdr (assq 'major-mode situation)) + mime-header-presentation-method-alist))))) + (setq nhb (point)) + (if header-presentation-method + (funcall header-presentation-method entity situation) + (mime-insert-header entity + mime-view-ignored-field-list + mime-view-visible-field-list)) + (run-hooks 'mime-display-header-hook) + (put-text-property nhb (point-max) 'mime-view-entity-header entity) (goto-char (point-max)) - (insert "\n") - )) + (insert "\n"))) + (setq nbb (point)) + (unless children + (if body-is-visible + (let ((body-presentation-method + (cdr (assq 'body-presentation-method situation)))) + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-display-text/plain entity situation))) + (unless header-is-visible + (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) + (put-text-property nb ne 'mime-view-situation situation) + (put-text-property nbb ne 'mime-view-entity-body 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)) - )) - "")) - )) - -(defun mime-raw-get-subject (param &optional encoding) - (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) - "")) + (if (and children body-is-visible) + (let ((body-presentation-method + (cdr (assq 'body-presentation-method situation)))) + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-display-multipart/mixed entity situation)))) + ))) ;;; @ MIME viewer mode @@ -895,11 +1172,10 @@ The compressed face will be piped to this command.") (play "Play current entity" mime-preview-play-current-entity) (extract "Extract current entity" mime-preview-extract-current-entity) (print "Print current entity" mime-preview-print-current-entity) - (x-face "Show X Face" mime-preview-display-x-face) ) "Menu for MIME Viewer") -(cond (running-xemacs +(cond ((featurep 'xemacs) (defvar mime-view-xemacs-popup-menu (cons mime-view-menu-title (mapcar (function @@ -914,16 +1190,35 @@ The compressed face will be piped to this command.") (set-buffer (event-buffer event)) (popup-menu 'mime-view-xemacs-popup-menu)) (defvar mouse-button-2 'button2) + (defvar mouse-button-3 'button3) ) (t + (defvar mime-view-popup-menu + (let ((menu (make-sparse-keymap mime-view-menu-title))) + (nconc menu + (mapcar (function + (lambda (item) + (list (intern (nth 1 item)) 'menu-item + (nth 1 item)(nth 2 item)) + )) + mime-view-menu-list)))) + (defun mime-view-popup-menu (event) + "Popup the menu in the MIME Viewer buffer" + (interactive "@e") + (let ((menu mime-view-popup-menu) events func) + (setq events (x-popup-menu t menu)) + (and events + (setq func (lookup-key menu (apply #'vector events))) + (commandp func) + (funcall func)))) (defvar mouse-button-2 [mouse-2]) + (defvar mouse-button-3 [mouse-3]) )) (defun mime-view-define-keymap (&optional default) (let ((mime-view-mode-map (if (keymapp default) (copy-keymap default) - (make-sparse-keymap) - ))) + (make-sparse-keymap)))) (define-key mime-view-mode-map "u" (function mime-preview-move-to-upper)) (define-key mime-view-mode-map @@ -950,13 +1245,33 @@ The compressed face will be piped to this command.") "e" (function mime-preview-extract-current-entity)) (define-key mime-view-mode-map "\C-c\C-p" (function mime-preview-print-current-entity)) + + (define-key mime-view-mode-map + "\C-c\C-t\C-f" (function mime-preview-toggle-header)) + (define-key mime-view-mode-map + "\C-c\C-th" (function mime-preview-toggle-header)) + (define-key mime-view-mode-map + "\C-c\C-t\C-c" (function mime-preview-toggle-content)) + + (define-key mime-view-mode-map + "\C-c\C-v\C-f" (function mime-preview-show-header)) + (define-key mime-view-mode-map + "\C-c\C-vh" (function mime-preview-show-header)) + (define-key mime-view-mode-map + "\C-c\C-v\C-c" (function mime-preview-show-content)) + + (define-key mime-view-mode-map + "\C-c\C-d\C-f" (function mime-preview-hide-header)) + (define-key mime-view-mode-map + "\C-c\C-dh" (function mime-preview-hide-header)) + (define-key mime-view-mode-map + "\C-c\C-d\C-c" (function mime-preview-hide-content)) + (define-key mime-view-mode-map "a" (function mime-preview-follow-current-entity)) (define-key mime-view-mode-map "q" (function mime-preview-quit)) (define-key mime-view-mode-map - "h" (function mime-preview-show-summary)) - (define-key mime-view-mode-map "\C-c\C-x" (function mime-preview-kill-buffer)) ;; (define-key mime-view-mode-map ;; "<" (function beginning-of-buffer)) @@ -971,7 +1286,7 @@ The compressed face will be piped to this command.") (define-key mime-view-mode-map [backspace] (function mime-preview-scroll-down-entity)) (if (functionp default) - (cond (running-xemacs + (cond ((featurep 'xemacs) (set-keymap-default-binding mime-view-mode-map default) ) (t @@ -982,11 +1297,13 @@ The compressed face will be piped to this command.") (define-key mime-view-mode-map mouse-button-2 (function mime-button-dispatcher)) ) - (cond (running-xemacs + (cond ((featurep 'xemacs) (define-key mime-view-mode-map mouse-button-3 (function mime-view-xemacs-popup-menu)) ) ((>= emacs-major-version 19) + (define-key mime-view-mode-map + mouse-button-3 (function mime-view-popup-menu)) (define-key mime-view-mode-map [menu-bar mime-view] (cons mime-view-menu-title (make-sparse-keymap mime-view-menu-title))) @@ -994,15 +1311,15 @@ The compressed face will be piped to this command.") (lambda (item) (define-key mime-view-mode-map (vector 'menu-bar 'mime-view (car item)) - (cons (nth 1 item)(nth 2 item)) - ) + (cons (nth 1 item)(nth 2 item))) )) - (reverse mime-view-menu-list) - ) + (reverse mime-view-menu-list)) )) - (use-local-map mime-view-mode-map) - (run-hooks 'mime-view-define-keymap-hook) - )) + ;; (run-hooks 'mime-view-define-keymap-hook) + mime-view-mode-map)) + +(defvar mime-view-mode-default-map (mime-view-define-keymap)) + (defsubst mime-maybe-hide-echo-buffer () "Clear mime-echo buffer and delete window for it." @@ -1018,7 +1335,109 @@ The compressed face will be piped to this command.") (bury-buffer buf) )))) -(defun mime-view-mode (&optional mother ctl encoding ibuf obuf +(defvar mime-view-redisplay nil) + +;;;###autoload +(defun mime-display-message (message &optional preview-buffer + mother default-keymap-or-function + original-major-mode keymap) + "View MESSAGE in MIME-View mode. + +Optional argument PREVIEW-BUFFER specifies the buffer of the +presentation. It must be either nil or a name of preview buffer. + +Optional argument MOTHER specifies mother-buffer of the preview-buffer. + +Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or +function. If it is a keymap, keymap of MIME-View mode will be added +to it. If it is a function, it will be bound as default binding of +keymap of MIME-View mode. + +Optional argument ORIGINAL-MAJOR-MODE is major-mode of representation +buffer of MESSAGE. If it is nil, current `major-mode' is used. + +Optional argument KEYMAP is keymap of MIME-View mode. If it is +non-nil, DEFAULT-KEYMAP-OR-FUNCTION is ignored. If it is nil, +`mime-view-mode-default-map' is used." + (mime-maybe-hide-echo-buffer) + (let ((win-conf (current-window-configuration))) + (or preview-buffer + (setq preview-buffer + (concat "*Preview-" (mime-entity-name message) "*"))) + (or original-major-mode + (setq original-major-mode major-mode)) + (let ((inhibit-read-only t)) + (set-buffer (get-buffer-create preview-buffer)) + (widen) + (erase-buffer) + (if mother + (setq mime-mother-buffer mother)) + (setq mime-preview-original-window-configuration win-conf) + (setq major-mode 'mime-view-mode) + (setq mode-name "MIME-View") + (mime-display-entity message nil + `((entity-button . invisible) + (header . visible) + (major-mode . ,original-major-mode)) + preview-buffer) + (use-local-map + (or keymap + (if default-keymap-or-function + (mime-view-define-keymap default-keymap-or-function) + mime-view-mode-default-map))) + (let ((point + (next-single-property-change (point-min) 'mime-view-entity))) + (if point + (goto-char point) + (goto-char (point-min)) + (search-forward "\n\n" nil t))) + (run-hooks 'mime-view-mode-hook) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + preview-buffer))) + +;;;###autoload +(defun mime-view-buffer (&optional raw-buffer preview-buffer mother + default-keymap-or-function + representation-type) + "View RAW-BUFFER in MIME-View mode. +Optional argument PREVIEW-BUFFER is either nil or a name of preview +buffer. +Optional argument DEFAULT-KEYMAP-OR-FUNCTION is nil, keymap or +function. If it is a keymap, keymap of MIME-View mode will be added +to it. If it is a function, it will be bound as default binding of +keymap of MIME-View mode. +Optional argument REPRESENTATION-TYPE is representation-type of +message. It must be nil, `binary' or `cooked'. If it is nil, +`cooked' is used as default." + (interactive) + (or raw-buffer + (setq raw-buffer (current-buffer))) + (or representation-type + (setq representation-type + (save-excursion + (set-buffer raw-buffer) + (cdr (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))) + ))) + (if (eq representation-type 'binary) + (setq representation-type 'buffer) + ) + (setq preview-buffer (mime-display-message + (mime-open-entity representation-type raw-buffer) + preview-buffer mother default-keymap-or-function)) + (or (get-buffer-window preview-buffer) + (let ((r-win (get-buffer-window raw-buffer))) + (if r-win + (set-window-buffer r-win preview-buffer) + (let ((m-win (and mother (get-buffer-window mother)))) + (if m-win + (set-window-buffer m-win preview-buffer) + (switch-to-buffer preview-buffer) + )))))) + +(defun mime-view-mode (&optional mother ctl encoding + raw-buffer preview-buffer default-keymap-or-function) "Major mode for viewing MIME message. @@ -1038,33 +1457,89 @@ v Decode current content as `play mode' e Decode current content as `extract mode' C-c C-p Decode current content as `print mode' a Followup to current content. -x Display X-Face q Quit button-2 Move to point under the mouse cursor and decode current content as `play mode' " (interactive) - (mime-maybe-hide-echo-buffer) - (let ((ret (mime-view-setup-buffers ctl encoding ibuf obuf)) - (win-conf (current-window-configuration)) + (unless mime-view-redisplay + (save-excursion + (if raw-buffer (set-buffer raw-buffer)) + (let ((type + (cdr + (or (assq major-mode mime-raw-representation-type-alist) + (assq t mime-raw-representation-type-alist))))) + (if (eq type 'binary) + (setq type 'buffer) + ) + (setq mime-message-structure (mime-open-entity type raw-buffer)) + (or (mime-entity-content-type mime-message-structure) + (mime-entity-set-content-type mime-message-structure ctl)) ) - (prog1 - (switch-to-buffer ret) - (setq mime-preview-original-window-configuration win-conf) - (if mother - (progn - (setq mime-mother-buffer mother) - )) - (mime-view-define-keymap default-keymap-or-function) - (let ((point - (next-single-property-change (point-min) 'mime-view-entity))) - (if point - (goto-char point) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - )) - (run-hooks 'mime-view-mode-hook) - ))) + (or (mime-entity-encoding mime-message-structure) + (mime-entity-set-encoding mime-message-structure encoding)) + )) + (mime-display-message mime-message-structure preview-buffer + mother default-keymap-or-function) + ) + + +;;; @@ utility +;;; + +(defun mime-preview-find-boundary-info (&optional with-children) + "Return boundary information of current part. +If WITH-CHILDREN, refer boundary surrounding current part and its branches." + (let (entity + p-beg p-end + entity-node-id len) + (while (and + (null (setq entity + (get-text-property (point) 'mime-view-entity))) + (> (point) (point-min))) + (backward-char)) + (setq p-beg (previous-single-property-change (point) 'mime-view-entity)) + (setq entity-node-id (and entity (mime-entity-node-id entity))) + (setq len (length entity-node-id)) + (cond ((null p-beg) + (setq p-beg + (if (eq (next-single-property-change (point-min) + 'mime-view-entity) + (point)) + (point) + (point-min))) + ) + ((eq (next-single-property-change p-beg 'mime-view-entity) + (point)) + (setq p-beg (point)) + )) + (setq p-end (next-single-property-change p-beg 'mime-view-entity)) + (cond ((null p-end) + (setq p-end (point-max)) + ) + ((null entity-node-id) + (setq p-end (point-max)) + ) + (with-children + (save-excursion + (catch 'tag + (let (e i) + (while (setq e + (next-single-property-change + (point) 'mime-view-entity)) + (goto-char e) + (let ((rc (mime-entity-node-id + (get-text-property (point) + 'mime-view-entity)))) + (or (and (>= (setq i (- (length rc) len)) 0) + (equal entity-node-id (nthcdr i rc))) + (throw 'tag nil))) + (setq p-end (or (next-single-property-change + (point) 'mime-view-entity) + (point-max))))) + (setq p-end (point-max)))) + )) + (vector p-beg p-end entity))) ;;; @@ playing @@ -1073,177 +1548,106 @@ button-2 Move to point under the mouse cursor (autoload 'mime-preview-play-current-entity "mime-play" "Play current entity." t) -(defun mime-preview-extract-current-entity () +(defun mime-preview-extract-current-entity (&optional ignore-examples) "Extract current entity into file (maybe). It decodes current entity to call internal or external method as \"extract\" mode. The method is selected from variable `mime-acting-condition'." - (interactive) - (mime-preview-play-current-entity "extract") + (interactive "P") + (mime-preview-play-current-entity ignore-examples "extract") ) -(defun mime-preview-print-current-entity () +(defun mime-preview-print-current-entity (&optional ignore-examples) "Print current entity (maybe). It decodes current entity to call internal or external method as \"print\" mode. The method is selected from variable `mime-acting-condition'." - (interactive) - (mime-preview-play-current-entity "print") + (interactive "P") + (mime-preview-play-current-entity ignore-examples "print") ) ;;; @@ following ;;; -(defun mime-preview-original-major-mode () - "Return major-mode of original buffer. -If a current buffer has mime-mother-buffer, return original major-mode -of the mother-buffer." - (if mime-mother-buffer - (save-excursion - (set-buffer mime-mother-buffer) - (mime-preview-original-major-mode) - ) - mime-preview-original-major-mode)) - (defun mime-preview-follow-current-entity () "Write follow message to current entity. It calls following-method selected from variable -`mime-view-following-method-alist'." +`mime-preview-following-method-alist'." (interactive) - (let (entity) - (while (null (setq entity - (get-text-property (point) 'mime-view-entity))) - (backward-char) - ) - (let* ((p-beg - (previous-single-property-change (point) 'mime-view-entity)) - p-end - (entity-node-id (mime-entity-node-id entity)) - (len (length entity-node-id)) - ) - (cond ((null p-beg) - (setq p-beg - (if (eq (next-single-property-change (point-min) - 'mime-view-entity) - (point)) - (point) - (point-min))) - ) - ((eq (next-single-property-change p-beg 'mime-view-entity) - (point)) - (setq p-beg (point)) - )) - (setq p-end (next-single-property-change p-beg 'mime-view-entity)) - (cond ((null p-end) - (setq p-end (point-max)) - ) - ((null entity-node-id) - (setq p-end (point-max)) - ) - (t - (save-excursion - (goto-char p-end) - (catch 'tag - (let (e) - (while (setq e - (next-single-property-change - (point) 'mime-view-entity)) - (goto-char e) - (let ((rc (mime-entity-node-id - (get-text-property (point) - 'mime-view-entity)))) - (or (equal entity-node-id - (nthcdr (- (length rc) len) rc)) - (throw 'tag nil) - )) - (setq p-end e) - )) - (setq p-end (point-max)) - )) - )) - (let* ((mode (mime-preview-original-major-mode)) - (new-name - (format "%s-%s" (buffer-name) (reverse entity-node-id))) - new-buf - (the-buf (current-buffer)) - (a-buf mime-raw-buffer) - fields) - (save-excursion - (set-buffer (setq new-buf (get-buffer-create new-name))) - (erase-buffer) - (insert-buffer-substring the-buf p-beg p-end) - (goto-char (point-min)) - (let ((entity-node-id (mime-entity-node-id entity)) ci str) - (while (progn - (setq - str - (save-excursion - (set-buffer a-buf) - (setq - ci - (mime-raw-find-entity-from-node-id entity-node-id)) - (save-restriction - (narrow-to-region - (mime-entity-point-min ci) - (mime-entity-point-max ci) - ) - (std11-header-string-except - (concat "^" - (apply (function regexp-or) fields) - ":") "")))) - (if (and - (eq (mime-entity-media-type ci) 'message) - (eq (mime-entity-media-subtype ci) 'rfc822)) - nil - (if str - (insert str) - ) - entity-node-id)) - (setq fields (std11-collect-field-names) - entity-node-id (cdr entity-node-id)) - ) - ) - (let ((rest mime-view-following-required-fields-list)) - (while rest - (let ((field-name (car rest))) - (or (std11-field-body field-name) - (insert - (format - (concat field-name - ": " - (save-excursion - (set-buffer the-buf) - (set-buffer mime-mother-buffer) - (set-buffer mime-raw-buffer) - (std11-field-body field-name) - ) - "\n"))) - )) - (setq rest (cdr rest)) - )) - (eword-decode-header) - ) - (let ((f (cdr (assq mode mime-view-following-method-alist)))) - (if (functionp f) - (funcall f new-buf) - (message - (format - "Sorry, following method for %s is not implemented yet." - mode)) + (let* ((boundary-info (mime-preview-find-boundary-info t)) + (p-beg (aref boundary-info 0)) + (p-end (aref boundary-info 1)) + (entity (aref boundary-info 2)) + pb-beg) + (if (or (get-text-property p-beg 'mime-view-entity-body) + (null entity)) + (setq pb-beg p-beg) + (setq pb-beg + (next-single-property-change + p-beg 'mime-view-entity-body nil + (or (next-single-property-change p-beg 'mime-view-entity) + p-end)))) + (let* ((mode (mime-preview-original-major-mode 'recursive)) + (entity-node-id (and entity (mime-entity-node-id entity))) + (new-name + (format "%s-%s" (buffer-name) (reverse entity-node-id))) + new-buf + (the-buf (current-buffer)) + fields) + (save-excursion + (set-buffer (setq new-buf (get-buffer-create new-name))) + (erase-buffer) + (insert ?\n) + (insert-buffer-substring the-buf pb-beg p-end) + (goto-char (point-min)) + (let ((current-entity + (if (and entity + (eq (mime-entity-media-type entity) 'message) + (eq (mime-entity-media-subtype entity) 'rfc822)) + (car (mime-entity-children entity)) + entity))) + (while (and current-entity + (if (and (eq (mime-entity-media-type + current-entity) 'message) + (eq (mime-entity-media-subtype + current-entity) 'rfc822)) + nil + (mime-insert-header current-entity fields) + t)) + (setq fields (std11-collect-field-names) + current-entity (mime-entity-parent current-entity)) )) - )))) - - -;;; @@ X-Face -;;; - -(defun mime-preview-display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime-raw-buffer) - (mime-view-x-face-function) - )) + (let ((rest mime-view-following-required-fields-list) + field-name ret) + (while rest + (setq field-name (car rest)) + (or (std11-field-body field-name) + (progn + (save-excursion + (set-buffer the-buf) + (let ((entity (when mime-mother-buffer + (set-buffer mime-mother-buffer) + (get-text-property (point) + 'mime-view-entity)))) + (while (and entity + (null (setq ret (mime-entity-fetch-field + entity field-name)))) + (setq entity (mime-entity-parent entity))))) + (if ret + (insert (concat field-name ": " ret "\n")) + ))) + (setq rest (cdr rest)) + )) + ) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + "Sorry, following method for %s is not implemented yet." + mode) + )) + ))) ;;; @@ moving @@ -1258,16 +1662,23 @@ If there is no upper entity, call function `mime-preview-quit'." (get-text-property (point) 'mime-view-entity))) (backward-char) ) - (let ((r (mime-raw-find-entity-from-node-id - (cdr (mime-entity-node-id cinfo)) - (get-text-property 1 'mime-view-entity))) + (let ((r (mime-entity-parent cinfo)) point) (catch 'tag (while (setq point (previous-single-property-change (point) 'mime-view-entity)) (goto-char point) - (if (eq r (get-text-property (point) 'mime-view-entity)) - (throw 'tag t) + (when (eq r (get-text-property (point) 'mime-view-entity)) + (if (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (>= point + (save-excursion + (move-to-window-line -1) + (forward-line (* -1 next-screen-context-lines)) + (beginning-of-line) + (point))))) + (recenter next-screen-context-lines)) + (throw 'tag t) ) ) (mime-preview-quit) @@ -1276,17 +1687,32 @@ If there is no upper entity, call function `mime-preview-quit'." (defun mime-preview-move-to-previous () "Move to previous entity. If there is no previous entity, it calls function registered in -variable `mime-view-over-to-previous-method-alist'." +variable `mime-preview-over-to-previous-method-alist'." (interactive) - (while (null (get-text-property (point) 'mime-view-entity)) + (while (and (not (bobp)) + (null (get-text-property (point) 'mime-view-entity))) (backward-char) ) - (let ((point - (previous-single-property-change (point) 'mime-view-entity))) - (if point - (goto-char point) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-previous-method-alist))) + (let ((point (previous-single-property-change (point) 'mime-view-entity))) + (if (and point + (>= point (point-min))) + (if (get-text-property (1- point) 'mime-view-entity) + (progn (goto-char point) + (if + (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (<= point + (save-excursion + (move-to-window-line 0) + (forward-line next-screen-context-lines) + (end-of-line) + (point))))) + (recenter (* -1 next-screen-context-lines)))) + (goto-char (1- point)) + (mime-preview-move-to-previous) + ) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) (if f (funcall (cdr f)) )) @@ -1295,13 +1721,33 @@ variable `mime-view-over-to-previous-method-alist'." (defun mime-preview-move-to-next () "Move to next entity. If there is no previous entity, it calls function registered in -variable `mime-view-over-to-next-method-alist'." +variable `mime-preview-over-to-next-method-alist'." (interactive) + (while (and (not (eobp)) + (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) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-next-method-alist))) + (if (and point + (<= point (point-max))) + (progn + (goto-char point) + (if (null (get-text-property point 'mime-view-entity)) + (mime-preview-move-to-next) + (and + (or (eq mime-preview-move-scroll t) + (and mime-preview-move-scroll + (>= point + (save-excursion + (move-to-window-line -1) + (forward-line + (* -1 next-screen-context-lines)) + (beginning-of-line) + (point))))) + (recenter next-screen-context-lines)) + )) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) (if f (funcall (cdr f)) )) @@ -1310,69 +1756,126 @@ variable `mime-view-over-to-next-method-alist'." (defun mime-preview-scroll-up-entity (&optional h) "Scroll up current entity. If reached to (point-max), it calls function registered in variable -`mime-view-over-to-next-method-alist'." +`mime-preview-over-to-next-method-alist'." (interactive) - (or h - (setq h (1- (window-height))) - ) - (if (= (point) (point-max)) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-next-method-alist))) - (if f - (funcall (cdr f)) - )) + (if (eobp) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-next-method-alist))) + (if f + (funcall (cdr f)) + )) (let ((point (or (next-single-property-change (point) 'mime-view-entity) - (point-max)))) - (forward-line h) - (if (> (point) point) - (goto-char point) - ) + (point-max))) + (bottom (window-end (selected-window)))) + (if (and (not h) + (> bottom point)) + (progn (goto-char point) + (recenter next-screen-context-lines)) + (condition-case nil + (scroll-up h) + (end-of-buffer + (goto-char (point-max))))) ))) (defun mime-preview-scroll-down-entity (&optional h) "Scroll down current entity. If reached to (point-min), it calls function registered in variable -`mime-view-over-to-previous-method-alist'." +`mime-preview-over-to-previous-method-alist'." (interactive) - (or h - (setq h (1- (window-height))) - ) - (if (= (point) (point-min)) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-previous-method-alist))) - (if f - (funcall (cdr f)) - )) - (let (point) - (save-excursion - (catch 'tag - (while (> (point) 1) - (if (setq point - (previous-single-property-change (point) - 'mime-view-entity)) - (throw 'tag t) - ) - (backward-char) - ) - (setq point (point-min)) + (if (bobp) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) + (if f + (funcall (cdr f)) )) - (forward-line (- h)) - (if (< (point) point) - (goto-char point) - )))) + (let ((point + (or (previous-single-property-change (point) 'mime-view-entity) + (point-min))) + (top (window-start (selected-window)))) + (if (and (not h) + (< top point)) + (progn (goto-char point) + (recenter (* -1 next-screen-context-lines))) + (condition-case nil + (scroll-down h) + (beginning-of-buffer + (goto-char (point-min))))) + ))) -(defun mime-preview-next-line-entity () - (interactive) - (mime-preview-scroll-up-entity 1) +(defun mime-preview-next-line-entity (&optional lines) + "Scroll up one line (or prefix LINES lines). +If LINES is negative, scroll down LINES lines." + (interactive "p") + (mime-preview-scroll-up-entity (or lines 1)) ) -(defun mime-preview-previous-line-entity () - (interactive) - (mime-preview-scroll-down-entity 1) +(defun mime-preview-previous-line-entity (&optional lines) + "Scrroll down one line (or prefix LINES lines). +If LINES is negative, scroll up LINES lines." + (interactive "p") + (mime-preview-scroll-down-entity (or lines 1)) ) +;;; @@ display +;;; + +(defun mime-preview-toggle-display (type &optional display) + (let ((situation (mime-preview-find-boundary-info t)) + (sym (intern (concat "*" (symbol-name type)))) + entity p-beg p-end) + (setq p-beg (aref situation 0) + p-end (aref situation 1) + entity (aref situation 2) + situation (get-text-property p-beg 'mime-view-situation)) + (cond ((eq display 'invisible) + (setq display nil)) + (display) + (t + (setq display + (memq (cdr (or (assq sym situation) + (assq type situation))) + '(nil invisible))))) + (setq situation (put-alist sym (if display + 'visible + 'invisible) + situation)) + (save-excursion + (let ((inhibit-read-only t)) + (delete-region p-beg p-end) + (mime-display-entity entity situation))) + (let ((ret (assoc situation mime-preview-situation-example-list))) + (if ret + (setcdr ret (1+ (cdr ret))) + (add-to-list 'mime-preview-situation-example-list + (cons situation 0)))))) + +(defun mime-preview-toggle-header (&optional force-visible) + (interactive "P") + (mime-preview-toggle-display 'header force-visible)) + +(defun mime-preview-toggle-content (&optional force-visible) + (interactive "P") + (mime-preview-toggle-display 'body force-visible)) + +(defun mime-preview-show-header () + (interactive) + (mime-preview-toggle-display 'header 'visible)) + +(defun mime-preview-show-content () + (interactive) + (mime-preview-toggle-display 'body 'visible)) + +(defun mime-preview-hide-header () + (interactive) + (mime-preview-toggle-display 'header 'invisible)) + +(defun mime-preview-hide-content () + (interactive) + (mime-preview-toggle-display 'body 'invisible)) + + ;;; @@ quitting ;;; @@ -1381,23 +1884,12 @@ If reached to (point-min), it calls function registered in variable It calls function registered in variable `mime-preview-quitting-method-alist'." (interactive) - (let ((r (assq mime-preview-original-major-mode + (let ((r (assq (mime-preview-original-major-mode) mime-preview-quitting-method-alist))) (if r (funcall (cdr r)) ))) -(defun mime-preview-show-summary () - "Show summary. -It calls function registered in variable -`mime-view-show-summary-method'." - (interactive) - (let ((r (assq mime-preview-original-major-mode - mime-view-show-summary-method))) - (if r - (funcall (cdr r)) - ))) - (defun mime-preview-kill-buffer () (interactive) (kill-buffer (current-buffer)) @@ -1409,6 +1901,11 @@ It calls function registered in variable (provide 'mime-view) -(run-hooks 'mime-view-load-hook) +(eval-when-compile + (setq mime-situation-examples-file nil) + ;; to avoid to read situation-examples-file at compile time. + ) + +(mime-view-read-situation-examples-file) ;;; mime-view.el ends here