X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=c4591b9ff9b42cee85ed7d8437756963c7b706ba;hb=refs%2Fheads%2Femy-1_13;hp=eee3635cb1cef693c365e2e379cf200f74ca7444;hpb=24aa7be3048c62204f7f73a6457423beff039406;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index eee3635..c4591b9 100644 --- a/mime-view.el +++ b/mime-view.el @@ -1,6 +1,6 @@ ;;; mime-view.el --- interactive MIME viewer for GNU Emacs -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; Created: 1994/07/13 @@ -8,7 +8,7 @@ ;; 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 @@ -27,22 +27,22 @@ ;;; Code: -(require 'std11) -(require 'mel) -(require 'eword-decode) -(require 'mime-parse) +(require 'emu) +(require 'mime) (require 'semi-def) (require 'calist) +(require 'alist) (require 'mailcap) ;;; @ 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) ")")) ;;; @ variables @@ -62,52 +62,118 @@ :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))) -;;; @ buffer local variables -;;; +(defcustom mime-preview-scroll-full-screen nil + "*When non-nil, always scroll full screen. +If nil, point will be moved to the next entity if exists." + :group 'mime-view + :type '(choice (const :tag "On" t) + (const :tag "Off" nil))) -;;; @@ in raw-buffer +(defcustom mime-view-force-inline-types '(text multipart) + "*List of MIME types that \"attachment\" should be ignored. +The element can be type or type/subtype. When t, inline everything +if possible." + :group 'mime-view + :type '(choice (const :tag "Nothing" nil) + (const :tag "All" t) + (list (repeat symbol)))) + +(defcustom mime-view-button-place-alist + '((message . around) + (application . before) + (multipart/alternative . around)) + "*Alist of MIME type or type/subtype vs. button place. +When around, button will be inserted before and after that part. +When after or before, button will be inserted that place. +If not specified, that type will not have button." + :group 'mime-view + :type '(choice (const :tag "Nothing" nil) + (list (repeat symbol)))) + +;; Rename this. +(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))) + +(defcustom mime-view-mailcap-files + (if (memq system-type '(ms-dos ms-windows windows-nt)) + '("~/mail.cap" "~/etc/mail.cap" "~/.mailcap") + '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" + "/usr/local/etc/mailcap")) + "*Search path of mailcap files." + :group 'mime + :type '(repeat file)) + +(defvar mime-view-automatic-conversion + (cond ((featurep 'xemacs) + 'automatic-conversion) + ((boundp 'MULE) + '*autoconv*) + (t + 'undecided))) + +;;; @ 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) + (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. + (t . cooked)) + "Alist of `major-mode' vs. representation-type of mime-raw-buffer. Each element looks like (SYMBOL . REPRESENTATION-TYPE). SYMBOL is -major-mode or t. t means default. REPRESENTATION-TYPE must be -`binary' or `cooked'. -This value is overridden by buffer local variable -`mime-raw-representation-type' if it is not nil.") - - -;;; @@ in preview-buffer +`major-mode' or t. t means default. REPRESENTATION-TYPE must be +`binary' or `cooked'.") + + +;; (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-message-structure' is used." +;; (or message-info +;; (setq message-info mime-message-structure)) +;; (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)))) +;; (make-obsolete 'mime-raw-find-entity-from-point "don't use it.") + + +;;; @ in preview-buffer (presentation space) ;;; (defvar mime-mother-buffer nil @@ -116,97 +182,165 @@ 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.") + "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-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-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)) + +(defun mime-view-entity-title (entity) + (or (mime-entity-read-field entity 'Content-Description) + (mime-entity-read-field entity 'Subject) + (mime-entity-filename entity) + "")) + +;; (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-message-structure' is used." +;; (mime-entity-node-id (mime-raw-find-entity-from-point point message-info))) + +;; (make-obsolete 'mime-raw-point-to-entity-node-id "don't use it.") + +;; (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-message-structure' is used." +;; (mime-entity-number (mime-raw-find-entity-from-point point message-info))) + +;; (make-obsolete 'mime-raw-point-to-entity-number "don't use it.") + +;; (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-message-structure' is used." +;; (or message-info +;; (setq message-info mime-message-structure)) +;; (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)) + +(defmacro mime-view-header-is-visible (situation) + `(eq (cdr (or (assq '*header ,situation) + (assq 'header ,situation))) + 'visible)) + +(defmacro mime-view-body-is-visible (situation) + `(eq (cdr (or (assq '*body ,situation) + (assq 'body ,situation))) + 'visible)) + +(defmacro mime-view-children-is-invisible (situation) + `(eq (cdr (or (assq '*children ,situation) + (assq 'children ,situation))) + 'invisible)) + +(defmacro mime-view-button-is-visible (situation) + ;; Kludge. + `(or (eq (or (cdr (assq '*entity-button ,situation)) + (cdr (assq 'entity-button ,situation))) + 'visible) + (and (not (eq (or (cdr (assq '*entity-button ,situation)) + (cdr (assq 'entity-button ,situation))) + 'invisible)) + (mime-view-entity-button-visible-p entity)))) ;;; @ presentation of preview ;;; @@ -217,133 +351,132 @@ If optional argument MESSAGE-INFO is not specified, ;;; @@@ predicate function ;;; -(defun mime-view-entity-button-visible-p (entity message-info) +;; #### fix flim +(defun mime-view-entity-type/subtype (entity) + (if (not (mime-entity-media-type entity)) + 'text/plain + (intern (format "%s/%s" + (mime-entity-media-type entity) + (mime-entity-media-subtype entity))))) + +(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-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))) - ) - ))))) +You can customize the visibility by changing `mime-view-button-place-alist'." + (or + ;; Check current entity + ;; type/subtype + (memq (cdr (assq (mime-view-entity-type/subtype entity) + mime-view-button-place-alist)) + '(around before)) + ;; type + (memq (cdr (assq (mime-entity-media-type entity) + mime-view-button-place-alist)) + '(around before)) + (and (mime-entity-parent entity) + (let ((prev-entity + (cadr (memq entity + (reverse (mime-entity-children + (mime-entity-parent entity))))))) + ;; When previous entity exists + (and prev-entity + (or + ;; Check previous entity + ;; type/subtype + (memq (cdr + (assq + (mime-view-entity-type/subtype prev-entity) + mime-view-button-place-alist)) + '(around after)) + ;; type + (memq (cdr + (assq + (mime-entity-media-type prev-entity) + mime-view-button-place-alist)) + '(around after)))))) + ;; default for everything. + (memq (cdr (assq t + mime-view-button-place-alist)) + '(around before)))) ;;; @@@ entity button generator ;;; -(defun mime-view-insert-entity-button (entity message-info subj) +(defun mime-view-insert-entity-button (entity &optional body-is-invisible) "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)) - (if (consp entity-node-id) - (mapconcat (function - (lambda (num) - (format "%s" (1+ num)) - )) - (reverse entity-node-id) ".") - "0")) - )) - (cond (access-type - (let ((server (assoc "server" params))) - (setq access-type (cdr access-type)) - (if server - (format "%s %s ([%s] %s)" - num subj access-type (cdr server)) - (let ((site (cdr (assoc "site" params))) - (dir (cdr (assoc "directory" params))) - ) - (format "%s %s ([%s] %s:%s)" - num subj 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))) - (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))) - ))) - (function mime-preview-play-current-entity)) - )) + (concat + (let ((access-type (assoc "access-type" params)) + (num (or (cdr (assoc "x-part-number" params)) + (if (consp entity-node-id) + (mapconcat (function + (lambda (num) + (format "%s" (1+ num)))) + (reverse entity-node-id) ".") + "0")))) + (cond (access-type + (let ((server (assoc "server" params))) + (setq access-type (cdr access-type)) + (if server + (format "%s %s ([%s] %s)" + num subject access-type (cdr server)) + (let ((site (cdr (assoc "site" params))) + (dir (cdr (assoc "directory" params))) + (url (cdr (assoc "url" params)))) + (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))) + (concat + num " " subject + (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)))))) + (if body-is-invisible + "..." + "")) + (function mime-preview-play-current-entity)))) ;;; @@ entity-header ;;; -;;; @@@ 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 ;;; @@ -351,12 +484,13 @@ 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))) (cond ((null s-field) - (cons (cons field-type field-value) calist) - ) + (cons (cons field-type field-value) calist)) (t calist)))) (define-calist-field-match-method @@ -369,16 +503,17 @@ Each elements are regexp of field-name.") (defvar mime-preview-condition nil "Condition-tree about how to display entity.") +;;(ctree-set-calist-strictly +;; 'mime-preview-condition '((type . application)(subtype . octet-stream) +;; (encoding . nil) +;; (body . visible))) + (ctree-set-calist-strictly - 'mime-preview-condition '((type . application)(subtype . octet-stream) - (encoding . nil) - (body . visible))) -(ctree-set-calist-strictly - 'mime-preview-condition '((type . application)(subtype . octet-stream) + 'mime-preview-condition '((type . application)(subtype . t) (encoding . "7bit") (body . visible))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . application)(subtype . octet-stream) + 'mime-preview-condition '((type . application)(subtype . t) (encoding . "8bit") (body . visible))) @@ -405,92 +540,500 @@ Each elements are regexp of field-name.") (ctree-set-calist-strictly 'mime-preview-condition '((body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . nil) (body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . enriched) (body . visible) - (body-presentation-method . mime-preview-text/enriched))) + (body-presentation-method . mime-display-text/enriched))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . richtext) (body . visible) - (body-presentation-method . mime-preview-text/richtext))) + (body-presentation-method . mime-display-text/richtext))) + +(ctree-set-calist-strictly + '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 . application)(subtype . t) + (encoding . t) + (body . invisible) + (body-presentation-method . mime-display-detect-application/octet-stream))) (ctree-set-calist-strictly 'mime-preview-condition '((type . text)(subtype . t) (body . visible) - (body-presentation-method . mime-preview-text/plain))) + (body-presentation-method . mime-display-text/plain))) (ctree-set-calist-strictly - 'mime-preview-condition '((type . message)(subtype . partial) - (body-presentation-method - . mime-preview-message/partial-button))) + 'mime-preview-condition + '((type . text)(subtype . x-rot13-47-48) + (body . visible) + (body-presentation-method . mime-display-text/x-rot13-47-48))) (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 . t) + (body . visible) + (body-presentation-method . mime-display-multipart/mixed))) + +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . partial) + (body . visible) + (body-presentation-method . mime-display-message/partial-button))) + +(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)))) + +(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)))) + +;; message/external-body has only one child. +(ctree-set-calist-strictly + 'mime-preview-condition + '((type . message)(subtype . external-body) + (body . visible) + (body-presentation-method . nil) + (childrens-situation (header . invisible) + (body . invisible) + (entity-button . visible)))) ;;; @@@ entity presentation ;;; -(autoload 'mime-preview-text/plain "mime-text") -(autoload 'mime-preview-text/enriched "mime-text") -(autoload 'mime-preview-text/richtext "mime-text") +(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 + (message "Wrong Content-Transfer-Encoding: %s" + (mime-entity-encoding entity)) + (if (fboundp 'mime-entity-body) + (insert (mime-entity-body entity)) + (insert "")))) + (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 (entity situation) + (save-restriction + (narrow-to-region (point-max) (point-max)) + (insert + (decode-coding-string + (mime-decode-string + (if (fboundp 'mime-entity-body) + ;; FLIM 1.14 + (mime-entity-body entity) + ;; #### This is wrong, but... + (mime-entity-content entity)) + (or (cdr (assq 'encoding situation)) + (if (fboundp 'mime-entity-body) + (mime-entity-encoding entity) + "7bit"))) + (or (cdr (assq 'coding situation)) + 'binary))))) + +(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))))) + +(defun mime-display-text/x-rot13-47-48 (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (mime-insert-text-content entity) + (goto-char (point-max)) + (if (not (eq (char-after (1- (point))) ?\n)) + (insert "\n")) + (mule-caesar-region (point-min) (point-max)) + (mime-add-url-buttons))) + +(put 'unpack 'lisp-indent-function 1) +(defmacro unpack (string &rest body) + `(let* ((*unpack*string* (string-as-unibyte ,string)) + (*unpack*index* 0)) + ,@body)) + +(defun unpack-skip (len) + (setq *unpack*index* (+ len *unpack*index*))) + +(defun unpack-fixed (len) + (prog1 + (substring *unpack*string* *unpack*index* (+ *unpack*index* len)) + (unpack-skip len))) + +(defun unpack-byte () + (char-int (aref (unpack-fixed 1) 0))) + +(defun unpack-short () + (let* ((b0 (unpack-byte)) + (b1 (unpack-byte))) + (+ (* 256 b0) b1))) + +(defun unpack-long () + (let* ((s0 (unpack-short)) + (s1 (unpack-short))) + (+ (* 65536 s0) s1))) + +(defun unpack-string () + (let ((len (unpack-byte))) + (unpack-fixed len))) + +(defun unpack-string-sjis () + (decode-mime-charset-string (unpack-string) 'shift_jis)) + +(defun postpet-decode (string) + (condition-case nil + (unpack string + (let (res) + (unpack-skip 4) + (set-alist 'res 'carryingcount (unpack-long)) + (unpack-skip 8) + (set-alist 'res 'sentyear (unpack-short)) + (set-alist 'res 'sentmonth (unpack-short)) + (set-alist 'res 'sentday (unpack-short)) + (unpack-skip 8) + (set-alist 'res 'petname (unpack-string-sjis)) + (set-alist 'res 'owner (unpack-string-sjis)) + (set-alist 'res 'pettype (unpack-fixed 4)) + (set-alist 'res 'health (unpack-short)) + (unpack-skip 2) + (set-alist 'res 'sex (unpack-long)) + (unpack-skip 1) + (set-alist 'res 'brain (unpack-byte)) + (unpack-skip 39) + (set-alist 'res 'happiness (unpack-byte)) + (unpack-skip 14) + (set-alist 'res 'petbirthyear (unpack-short)) + (set-alist 'res 'petbirthmonth (unpack-short)) + (set-alist 'res 'petbirthday (unpack-short)) + (unpack-skip 8) + (set-alist 'res 'from (unpack-string)) + (unpack-skip 5) + (unpack-skip 160) + (unpack-skip 4) + (unpack-skip 8) + (unpack-skip 8) + (unpack-skip 26) + (set-alist 'res 'treasure (unpack-short)) + (set-alist 'res 'money (unpack-long)) + res)) + (error nil))) + +(defun mime-display-application/x-postpet (entity situation) + (save-restriction + (narrow-to-region (point-max)(point-max)) + (let ((pet (postpet-decode (mime-entity-content entity)))) + (if pet + (insert "Petname: " (cdr (assq 'petname pet)) "\n" + "Owner: " (cdr (assq 'owner pet)) "\n" + "Pettype: " (cdr (assq 'pettype pet)) "\n" + "From: " (cdr (assq 'from pet)) "\n" + "CarryingCount: " (int-to-string (cdr (assq 'carryingcount pet))) "\n" + "SentYear: " (int-to-string (cdr (assq 'sentyear pet))) "\n" + "SentMonth: " (int-to-string (cdr (assq 'sentmonth pet))) "\n" + "SentDay: " (int-to-string (cdr (assq 'sentday pet))) "\n" + "PetbirthYear: " (int-to-string (cdr (assq 'petbirthyear pet))) "\n" + "PetbirthMonth: " (int-to-string (cdr (assq 'petbirthmonth pet))) "\n" + "PetbirthDay: " (int-to-string (cdr (assq 'petbirthday pet))) "\n" + "Health: " (int-to-string (cdr (assq 'health pet))) "\n" + "Sex: " (int-to-string (cdr (assq 'sex pet))) "\n" + "Brain: " (int-to-string (cdr (assq 'brain pet))) "\n" + "Happiness: " (int-to-string (cdr (assq 'happiness pet))) "\n" + "Treasure: " (int-to-string (cdr (assq 'treasure pet))) "\n" + "Money: " (int-to-string (cdr (assq 'money pet))) "\n") + (insert "Invalid format\n")) + (run-hooks 'mime-display-application/x-postpet-hook)))) + (defvar mime-view-announcement-for-message/partial (if (and (>= emacs-major-version 19) window-system) "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer ]] -\[[ or click here by mouse button-2. ]]" +This is message/partial style split message. +Please press `v' key in this buffer or click here by mouse button-2." "\ -\[[ This is message/partial style split message. ]] -\[[ Please press `v' key in this buffer. ]]" - )) +This is message/partial style split message. +Please press `v' key in this buffer.")) -(defun mime-preview-message/partial-button (&optional entity situation) +(defun mime-display-message/partial-button (&optional entity situation) (save-restriction (goto-char (point-max)) (if (not (search-backward "\n\n" nil t)) - (insert "\n") - ) + (insert "\n")) (goto-char (point-max)) - (narrow-to-region (point-max)(point-max)) - (insert mime-view-announcement-for-message/partial) - (mime-add-button (point-min)(point-max) - #'mime-preview-play-current-entity) - )) - -(defun mime-preview-multipart/mixed (entity situation) + ;;(narrow-to-region (point-max)(point-max)) + ;;(insert mime-view-announcement-for-message/partial) + ;; (mime-add-button (point-min)(point-max) + ;; #'mime-preview-play-current-entity) + (mime-insert-button mime-view-announcement-for-message/partial + #'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))))) + +(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 + (or (ctree-match-calist + mime-preview-condition + (append (mime-entity-situation child) + default-situation)) + 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 + (del-alist 'body-presentation-method + (copy-alist situation))))) + (setq children (cdr children) + situations (cdr situations) + i (1+ i))))) + +(defun mime-display-multipart/encrypted (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))) + (mime-display-entity (car children) nil default-situation) + (mime-display-entity (cadr children) nil + (put-alist '*entity-button + 'invisible default-situation)) + (del-alist '*entity-button default-situation) + (setq children (nth 2 children)) + ;; This shouldn't happen. (while children - (mime-view-display-entity (car children) mime-raw-message-info - mime-raw-buffer (current-buffer) - default-situation) - (setq children (cdr children)) - ))) + (mime-display-entity (car children) nil default-situation) + (setq children (cdr children))))) + +(defun mime-display-detect-application/octet-stream (entity situation) + "Detect unknown ENTITY and display it inline. +This can only handle gzipped contents." + (or (and (mime-entity-filename entity) + (string-match "\\.gz$" (mime-entity-filename entity)) + (mime-display-gzipped entity situation)) + (mime-display-text/plain entity situation))) + +(defun mime-display-gzipped (entity situation) + "Ungzip gzipped part and display." + (insert + (decode-coding-string + (with-temp-buffer + ;; #### Kludge to make FSF Emacs happy. + (if (featurep 'xemacs) + (insert (mime-entity-content entity)) + (let ((content (mime-entity-content entity))) + (if (not (multibyte-string-p content)) + ;; I really hate this brain-damaged function. + (set-buffer-multibyte nil)) + (insert content))) + (as-binary-process + (call-process-region (point-min) (point-max) "gzip" t t + nil "-cd")) + ;; Oh my goodness. + (when (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte t)) + (buffer-string)) + mime-view-automatic-conversion)) + t) + +(defun mime-preview-inline () + "View part as text without code conversion." + (interactive) + (let ((inhibit-read-only t) + (entity (get-text-property (point) 'mime-view-entity)) + (situation (get-text-property (point) 'mime-view-situation)) + start) + (when (and entity + (not (get-text-property (point) 'mime-view-entity-header)) + (not (memq (mime-entity-media-type entity) + '(multipart message)))) + (setq start (or (and (not (mime-entity-parent entity)) + (1+ (previous-single-property-change + (point) + 'mime-view-entity-header))) + (and (not (eq (point) (point-min))) + (not (eq (get-text-property (1- (point)) + 'mime-view-entity) + entity)) + (point)) + (previous-single-property-change (point) + 'mime-view-entity) + (point))) + (delete-region start + (1- + (or (next-single-property-change (point) + 'mime-view-entity) + (point-max)))) + (setq start (point)) + (if (mime-view-entity-button-visible-p entity) + (mime-view-insert-entity-button entity)) + (insert (mime-entity-content entity)) + (if (and (bolp) (eolp)) + (delete-char 1) + (forward-char 1)) + (add-text-properties start (point) + (list 'mime-view-entity entity + 'mime-view-situation situation)) + (goto-char start)))) + +(defun mime-preview-text (&optional ask-coding) + "View part as text. MIME charset will be guessed automatically. +With prefix, it prompts for coding-system." + (interactive "P") + (let ((inhibit-read-only t) + (mime-view-force-inline-types t) + (position (mime-preview-entity-boundary)) + (coding (if ask-coding + (or (read-coding-system "Coding system: ") + mime-view-automatic-conversion) + mime-view-automatic-conversion)) + (cte (if ask-coding + (completing-read "Content Transfer Encoding: " + (mime-encoding-alist) nil t))) + entity situation) + (setq entity (get-text-property (car position) 'mime-view-entity) + situation (get-text-property (car position) 'mime-view-situation)) + (setq situation + (put-alist + 'encoding cte + (put-alist + 'coding coding + (put-alist + 'body-presentation-method 'mime-display-text + (put-alist '*body 'visible situation))))) + (save-excursion + (delete-region (car position) (cdr position)) + (mime-display-entity entity situation)))) + +(defun mime-preview-type () + "View part as text without code conversion." + (interactive) + (mime-preview-toggle-content t)) + +(defun mime-preview-buttonize () + (interactive) + (save-excursion + (goto-char (point-min)) + (let (point) + (while (setq point (next-single-property-change + (point) 'mime-view-entity)) + (goto-char point) + (unless (get-text-property (point) 'mime-button) + (mime-preview-toggle-button t)))))) +(defun mime-preview-unbuttonize () + (interactive) + (save-excursion + (goto-char (point-min)) + (let (point) + (while (setq point (next-single-property-change + (point) 'mime-view-entity)) + (goto-char point) + (when (get-text-property (point) 'mime-button) + ;; Remove invisible text following XPM buttons. + (static-if (featurep 'xemacs) + (let ((extent (extent-at (point) nil 'invisible)) + (inhibit-read-only t)) + (if extent + (delete-region (extent-start-position extent) + (extent-end-position extent))))) + (mime-preview-toggle-button 'hide)))))) + ;;; @ acting-condition ;;; @@ -498,127 +1041,111 @@ Each elements are regexp of field-name.") (defvar mime-acting-condition nil "Condition-tree about how to process entity.") -(if (file-readable-p mailcap-file) - (let ((entries (mailcap-parse-file))) - (while entries - (let ((entry (car entries)) - view print shared) - (while entry - (let* ((field (car entry)) - (field-type (car field))) - (cond ((eq field-type 'view) (setq view field)) - ((eq field-type 'print) (setq print field)) - ((memq field-type '(compose composetyped edit))) - (t (setq shared (cons field shared)))) - ) - (setq entry (cdr entry)) - ) - (setq shared (nreverse shared)) - (ctree-set-calist-with-default - 'mime-acting-condition - (append shared (list '(mode . "play")(cons 'method (cdr view))))) - (if print - (ctree-set-calist-with-default - 'mime-acting-condition - (append shared - (list '(mode . "print")(cons 'method (cdr view)))) - )) - ) - (setq entries (cdr entries)) - ))) - -;; (ctree-set-calist-strictly -;; 'mime-acting-condition -;; '((type . t)(subtype . t)(mode . "extract") -;; (method . mime-method-to-save))) +(defvar mime-view-mailcap-parsed-p nil) + +;; ### Fix flim +(defun mime-view-parse-mailcap-files (&optional path) + (if (not (or path (setq path (getenv "MAILCAPS")))) + (setq path mime-view-mailcap-files)) + (let ((fnames (reverse + (if (stringp path) + (parse-colon-path path) + path))) + fname) + (setq mime-view-mailcap-parsed-p t) + (with-temp-buffer + (while fnames + (setq fname (car fnames)) + (when (and (file-readable-p fname) + (file-regular-p fname)) + (insert-file-contents fname) + (unless (bolp) + (insert "\n"))) + (setq fnames (cdr fnames))) + (mailcap-parse-buffer)))) + +(defun mime-view-parse-mailcap (&optional path force) + "Parse out all the mailcaps specified in a path string PATH. +Components of PATH are separated by the `path-separator' character +appropriate for this system. If FORCE, re-parse even if already +parsed. If PATH is omitted, use the value of `mime-view-mailcap-files'." + (interactive (list nil t)) + (when (or (not mime-view-mailcap-parsed-p) + force) + (let ((entries (mime-view-parse-mailcap-files path))) + (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-parse-mailcap) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . application)(subtype . octet-stream) + (mode . "play") + (method . mime-detect-content))) + (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) -;; )) + (method . mime-save-content))) + (ctree-set-calist-strictly 'mime-acting-condition '((type . text)(subtype . x-rot13-47)(mode . "play") - (method . mime-method-to-display-caesar) - )) + (method . mime-view-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) -;; )) + (method . mime-view-caesar))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . rfc822)(mode . "play") - (method . mime-method-to-display-message/rfc822) - )) + (method . mime-view-message/rfc822))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . partial)(mode . "play") - (method . mime-method-to-store-message/partial) - )) + (method . mime-store-message/partial-piece))) (ctree-set-calist-strictly 'mime-acting-condition '((type . message)(subtype . external-body) ("access-type" . "anon-ftp") - (method . mime-method-to-display-message/external-ftp) - )) + (method . mime-view-message/external-anon-ftp))) + +(ctree-set-calist-strictly + 'mime-acting-condition + '((type . message)(subtype . external-body) + ("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))) ;;; @ quitting method @@ -627,220 +1154,119 @@ Each elements are regexp of field-name.") (defvar mime-preview-quitting-method-alist '((mime-show-message-mode . mime-preview-quitting-method-for-mime-show-message-mode)) - "Alist of major-mode vs. quitting-method of mime-view.") + "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 - "Alist of major-mode vs. following-method of mime-view.") +(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")) - - ;;; @ 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-entity message-info message-info - the-buf obuf - '((entity-button . invisible) - (header . visible) - )) - (set-buffer-modified-p nil) - ) - (setq buffer-read-only t) - (set-buffer the-buf) - ) - (setq mime-preview-buffer obuf) - ) - -(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)) - (content-type (mime-entity-content-type entity)) - (encoding (mime-entity-encoding entity)) - end-of-header e nb ne subj) - (set-buffer ibuf) - (goto-char start) - (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) - ) +(defun mime-display-entity (entity &optional situation + default-situation preview-buffer) + "Display mime-entity ENTITY." + (or preview-buffer + (setq preview-buffer (current-buffer))) + (in-calist-package 'mime-view) + (or situation + (setq situation + (or (ctree-match-calist mime-preview-condition + (append (mime-entity-situation entity) + default-situation)) + default-situation))) + (let ((button-is-visible (mime-view-button-is-visible situation)) + (header-is-visible + (mime-view-header-is-visible situation)) + (header-presentation-method + (or (cdr (assq '*header-presentation-method situation)) + (cdr (assq 'header-presentation-method situation)) + (cdr (assq (cdr (assq 'major-mode situation)) + mime-header-presentation-method-alist)))) + (body-is-visible + (mime-view-body-is-visible situation)) + (body-presentation-method + (cdr (assq 'body-presentation-method situation))) + (children (mime-entity-children entity)) + nb ne nhb nbb) + ;; Check if attachment is specified. + ;; if inline is forced or not. + (unless (or (eq t mime-view-force-inline-types) + (memq (mime-entity-media-type entity) + mime-view-force-inline-types) + (memq (mime-view-entity-type/subtype entity) + mime-view-force-inline-types) + ;; whether Content-Disposition header exists. + (not (mime-entity-content-disposition entity)) + (eq 'inline + (mime-content-disposition-type + (mime-entity-content-disposition entity)))) + ;; This is attachment. + ;; But show header when this is root entity. + (if (mime-root-entity-p entity) + (progn (setq body-is-visible nil) + (put-alist 'body 'invisible situation)) + (setq header-is-visible nil) + (put-alist 'header 'invisible situation))) + (set-buffer preview-buffer) + (setq nb (point)) (save-restriction - (narrow-to-region start end) - (setq subj (eword-decode-string (mime-raw-get-subject entity))) - ) - (let* ((situation - (or - (ctree-match-calist mime-preview-condition - (append - (or content-type - (make-mime-content-type 'text 'plain)) - (list* (cons 'encoding encoding) - (cons 'major-mode major-mode) - default-situation))) - default-situation)) - (button-is-invisible - (eq (cdr (assq 'entity-button situation)) 'invisible)) - (header-is-visible - (eq (cdr (assq 'header situation)) 'visible)) - (body-presentation-method - (cdr (assq 'body-presentation-method situation))) - (children (mime-entity-children entity))) - (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) - ))) - (children) - ((functionp body-presentation-method) - (funcall body-presentation-method entity situation) - ) + (if button-is-visible + (mime-view-insert-entity-button entity + ;; work around composite type + (not (or children + body-is-visible)))) + (when header-is-visible + (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")) + (setq nbb (point)) + (cond (children) + ((and body-is-visible + (functionp body-presentation-method)) + (funcall body-presentation-method entity situation)) (t - (when button-is-invisible + ;; When both body and button is not displayed, + ;; there should be a button to indicate there's a part. + (unless button-is-visible (goto-char (point-max)) - (mime-view-insert-entity-button entity message-info subj) - ) - (or header-is-visible - (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) - (if children - (mime-preview-multipart/mixed entity situation) - ) - ))) - -(defun mime-raw-get-uu-filename () - (save-excursion - (if (re-search-forward "^begin [0-9]+ " nil t) - (if (looking-at ".+$") - (buffer-substring (match-beginning 0)(match-end 0)) - )))) - -(defun mime-raw-get-subject (entity) - (or (std11-find-field-body '("Content-Description" "Subject")) - (let ((ret (mime-entity-content-disposition entity))) - (and ret - (setq ret (mime-content-disposition-filename ret)) - (std11-strip-quoted-string ret) - )) - (let ((ret (mime-entity-content-type entity))) - (and ret - (setq ret - (cdr - (let ((param (mime-content-type-parameters ret))) - (or (assoc "name" param) - (assoc "x-name" param)) - ))) - (std11-strip-quoted-string ret) - )) - (if (member (mime-entity-encoding entity) - mime-view-uuencode-encoding-name-list) - (mime-raw-get-uu-filename)) - "")) - + (mime-view-insert-entity-button entity + ;; work around composite type + (not (or children + body-is-visible)))) + (unless header-is-visible + (goto-char (point-max)) + (insert "\n")))) + (setq ne (point-max))) + (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) + (if (and children body-is-visible) + (if (functionp body-presentation-method) + (funcall body-presentation-method entity situation) + (mime-display-multipart/mixed entity situation))))) ;;; @ MIME viewer mode ;;; @@ -855,17 +1281,17 @@ 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") + (raw "View text without code conversion" mime-preview-inline) + (text "View text with code conversion" mime-preview-text) + (type "View internally as type" mime-preview-type)) + "Menu for MIME Viewer.") -(cond (running-xemacs +(cond ((featurep 'xemacs) (defvar mime-view-xemacs-popup-menu (cons mime-view-menu-title (mapcar (function (lambda (item) - (vector (nth 1 item)(nth 2 item) t) - )) + (vector (nth 1 item)(nth 2 item) t))) mime-view-menu-list))) (defun mime-view-xemacs-popup-menu (event) "Popup the menu in the MIME Viewer buffer" @@ -873,17 +1299,14 @@ The compressed face will be piped to this command.") (select-window (event-window event)) (set-buffer (event-buffer event)) (popup-menu 'mime-view-xemacs-popup-menu)) - (defvar mouse-button-2 'button2) - ) + (defvar mouse-button-2 'button2)) (t - (defvar mouse-button-2 [mouse-2]) - )) + (defvar mouse-button-2 [mouse-2]))) (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 @@ -909,14 +1332,36 @@ The compressed face will be piped to this command.") (define-key mime-view-mode-map "e" (function mime-preview-extract-current-entity)) (define-key mime-view-mode-map + "\C-c\C-e" (function mime-preview-extract-current-entity)) + (define-key mime-view-mode-map + "i" (function mime-preview-inline)) + (define-key mime-view-mode-map + "c" (function mime-preview-text)) + (define-key mime-view-mode-map + "t" (function mime-preview-type)) + (define-key mime-view-mode-map + "b" (function mime-preview-buttonize)) + (define-key mime-view-mode-map + "B" (function mime-preview-unbuttonize)) + (define-key mime-view-mode-map + "\C-c\C-t\C-h" (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-tc" (function mime-preview-toggle-content)) + (define-key mime-view-mode-map + "\C-c\C-tH" (function mime-preview-toggle-all-header)) + (define-key mime-view-mode-map + "\C-c\C-tb" (function mime-preview-toggle-button)) + (define-key mime-view-mode-map "\C-c\C-p" (function mime-preview-print-current-entity)) (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)) @@ -931,21 +1376,17 @@ 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 - (set-keymap-default-binding mime-view-mode-map default) - ) + (cond ((featurep 'xemacs) + (set-keymap-default-binding mime-view-mode-map default)) (t (setq mime-view-mode-map - (append mime-view-mode-map (list (cons t default)))) - ))) + (append mime-view-mode-map (list (cons t default))))))) (if mouse-button-2 (define-key mime-view-mode-map - mouse-button-2 (function mime-button-dispatcher)) - ) - (cond (running-xemacs + mouse-button-2 (function mime-button-dispatcher))) + (cond ((featurep 'xemacs) (define-key mime-view-mode-map - mouse-button-3 (function mime-view-xemacs-popup-menu)) - ) + mouse-button-3 (function mime-view-xemacs-popup-menu))) ((>= emacs-major-version 19) (define-key mime-view-mode-map [menu-bar mime-view] (cons mime-view-menu-title @@ -954,15 +1395,10 @@ 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)) - ) - )) - (reverse mime-view-menu-list) - ) - )) + (cons (nth 1 item)(nth 2 item))))) + (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))) (defsubst mime-maybe-hide-echo-buffer () "Clear mime-echo buffer and delete window for it." @@ -973,12 +1409,99 @@ The compressed face will be piped to this command.") (erase-buffer) (let ((win (get-buffer-window buf))) (if win - (delete-window win) - )) - (bury-buffer buf) - )))) + (delete-window win))) + (bury-buffer buf))))) + +(defvar mime-view-redisplay nil) + +;;;###autoload +(defun mime-display-message (message &optional preview-buffer + mother default-keymap-or-function + original-major-mode) + "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. -(defun mime-view-mode (&optional mother ctl encoding ibuf obuf +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." + (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 + (list (cons 'entity-button 'invisible) + (cons 'header 'visible) + (cons 'major-mode original-major-mode)) + preview-buffer) + (mime-view-define-keymap default-keymap-or-function) + (set (make-local-variable 'line-move-ignore-invisible) t) + (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. @@ -998,33 +1521,27 @@ 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' -" + 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)) - ) - (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) - ))) + (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-internal + mime-message-structure ctl))) + (or (mime-entity-encoding mime-message-structure) + (mime-entity-set-encoding-internal mime-message-structure encoding)))) + (mime-display-message mime-message-structure preview-buffer + mother default-keymap-or-function)) ;;; @@ playing @@ -1033,177 +1550,115 @@ 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) + (let (entity position entity-node-id header-exists) (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) + (backward-char)) + (setq position (mime-preview-entity-boundary)) + (setq entity-node-id (mime-entity-node-id entity) + header-exists + ;; When on an invisible entity, there's no header. + (or (mime-view-header-is-visible + (get-text-property (car position) 'mime-view-situation)) + ;; We are on a rfc822 button. + (and (eq 'message (mime-entity-media-type + entity)) + (eq 'rfc822 (mime-entity-media-subtype + entity)) + (get-text-property + (next-single-property-change + (car position) 'mime-button + nil (point-max)) + 'mime-view-entity-header)))) + (let* ((mode (mime-preview-original-major-mode 'recursive)) + (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) + ;; Compatibility kludge. + ;; FSF Emacs can only take substring of current-buffer. + (insert + (save-excursion + (set-buffer the-buf) + (buffer-substring-no-properties (car position) + (cdr position)))) + (if header-exists + (delete-region (goto-char (point-min)) + (re-search-forward "^$")) (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)) - )) - )))) - - -;;; @@ X-Face -;;; - -(defun mime-preview-display-x-face () - (interactive) - (save-window-excursion - (set-buffer mime-raw-buffer) - (mime-view-x-face-function) - )) + (insert "\n")) + (goto-char (point-min)) + (let ((current-entity + (if (and (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)))) + (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)))) + (mime-decode-header-in-buffer)) + (let ((f (cdr (assq mode mime-preview-following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + (format + "Sorry, following method for %s is not implemented yet." + mode))))))) ;;; @@ moving @@ -1216,132 +1671,290 @@ If there is no upper entity, call function `mime-preview-quit'." (let (cinfo) (while (null (setq cinfo (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))) + (backward-char)) + (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) - ) - ) - (mime-preview-quit) - )))) + (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))))) (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)) - (backward-char) - ) + (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 + (if (and point + (>= point (point-min))) (if (get-text-property (1- point) 'mime-view-entity) - (goto-char point) + (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 next-screen-context-lines))) (goto-char (1- point)) - (mime-preview-move-to-previous) - ) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-previous-method-alist))) + (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)) - )) - ))) + (funcall (cdr f))))))) (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 (null (get-text-property (point) 'mime-view-entity)) - (forward-char) - ) + (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 + (if (and point + (<= point (point-max))) (progn (goto-char point) (if (null (get-text-property point 'mime-view-entity)) (mime-preview-move-to-next) - )) - (let ((f (assq mime-preview-original-major-mode - mime-view-over-to-next-method-alist))) + (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)) - )) - ))) + (funcall (cdr f))))))) (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) + (not mime-preview-scroll-full-screen)) + (progn (goto-char point) + (recenter next-screen-context-lines)) + (condition-case nil + (let (window-pixel-scroll-increment) + (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'." - (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 (not (bobp)) - (if (setq point - (previous-single-property-change (point) - 'mime-view-entity)) - (throw 'tag t) - ) - (backward-char) - ) - (setq point (point-min)) - )) - (forward-line (- h)) - (if (< (point) point) - (goto-char point) - )))) - -(defun mime-preview-next-line-entity () +`mime-preview-over-to-previous-method-alist'." (interactive) - (mime-preview-scroll-up-entity 1) - ) - -(defun mime-preview-previous-line-entity () - (interactive) - (mime-preview-scroll-down-entity 1) - ) - + (if (bobp) + (let ((f (assq (mime-preview-original-major-mode) + mime-preview-over-to-previous-method-alist))) + (if f + (funcall (cdr f)))) + (let ((point + (or (previous-single-property-change (point) 'mime-view-entity) + (point-min))) + (top (window-start (selected-window)))) + (if (and (not h) + (< top point) + (not mime-preview-scroll-full-screen)) + (progn (goto-char point) + (recenter (* -1 next-screen-context-lines))) + (condition-case nil + (let (window-pixel-scroll-increment) + (scroll-down h)) + (beginning-of-buffer + (goto-char (point-min)))))))) + +(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 (&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))) + +(defun mime-preview-entity-boundary (&optional point) + (or point + (setq point (point))) + (and (eq point (point-max)) + (setq point (1- (point-max)))) + (let ((entity (get-text-property point 'mime-view-entity)) + (start (previous-single-property-change (1+ point) 'mime-view-entity + nil (point-min))) + end done) + (if (not (mime-entity-node-id entity)) + (setq end (point-max)) + (while (and (mime-entity-children entity) + (not done)) + (if (not (mime-view-body-is-visible + (get-text-property point 'mime-view-situation))) + (setq done t) + ;; If the part is shown, search the last part. + (let* ((child (car (last (mime-entity-children entity)))) + (node-id (mime-entity-node-id child)) + (tmp-node-id (mime-entity-node-id + (get-text-property point + 'mime-view-entity)))) + (while (or (< (length tmp-node-id) + (length node-id)) + (not (eq (nthcdr (- (length tmp-node-id) + (length node-id)) + tmp-node-id) + node-id))) + (setq point + (next-single-property-change point 'mime-view-entity) + tmp-node-id (mime-entity-node-id + (get-text-property point + 'mime-view-entity)))) + (setq entity child)))) + (setq end (next-single-property-change + point 'mime-view-entity nil (point-max)))) + (cons start end))) + +(defun mime-preview-toggle-header (&optional show) + "Toggle display of entity header. +When prefix is given, it always displays the header." + (interactive "P") + (let ((inhibit-read-only t) + (mime-view-force-inline-types t) + (position (mime-preview-entity-boundary)) + entity header-is-visible situation) + (setq entity (get-text-property (car position) 'mime-view-entity) + situation (get-text-property (car position) 'mime-view-situation)) + (setq header-is-visible (mime-view-header-is-visible situation)) + (save-excursion + (delete-region (car position) (cdr position)) + (if (or show (not header-is-visible)) + (mime-display-entity + entity + (del-alist '*entity-button + (put-alist '*header 'visible + situation))) + (mime-display-entity + entity + (put-alist '*entity-button + 'visible + (put-alist '*header 'invisible + situation))))))) + +(defun mime-preview-toggle-all-header (&optional show) + "Toggle display of entity header. +When prefix is given, it always displays the header." + (interactive "P") + (let ((inhibit-read-only t) + (mime-view-force-inline-types t) + (position (mime-preview-entity-boundary)) + entity header-is-visible situation) + (setq entity (get-text-property (car position) 'mime-view-entity) + situation (get-text-property (car position) 'mime-view-situation)) + (setq header-is-visible (mime-view-header-is-visible situation)) + (save-excursion + (delete-region (car position) (cdr position)) + (if (or show (not header-is-visible)) + (mime-display-entity + entity + (del-alist '*entity-button + (del-alist '*header + (del-alist '*header-presentation-method + situation)))) + (mime-display-entity + entity + (put-alist + '*entity-button + 'visible + (put-alist + '*header 'invisible + (put-alist '*header-presentation-method + #'(lambda (entity situation) + (mime-insert-header + entity nil '(".*"))) + situation)))))))) + +(defun mime-preview-toggle-content (&optional show) + "Toggle display of entity body. +When prefix is given, it always displays the content." + (interactive "P") + (let ((inhibit-read-only t) + (mime-view-force-inline-types t) + (position (mime-preview-entity-boundary)) + entity situation) + (setq entity (get-text-property (car position) 'mime-view-entity) + situation (get-text-property (car position) 'mime-view-situation)) + (setq situation + (if (or show (not (mime-view-body-is-visible situation))) + (del-alist + '*entity-button + (put-alist '*body 'visible situation)) + (put-alist + '*entity-button 'visible + (put-alist '*body 'invisible situation)))) + (save-excursion + (delete-region (car position) (cdr position)) + (mime-display-entity entity situation)))) + +(defun mime-preview-toggle-button (&optional condition) + "Toggle display of entity button. +When prefix is given, it always displays the content. +If condition is 'hide, hide all buttons." + (interactive "P") + (let ((inhibit-read-only t) + (mime-view-force-inline-types t) + (position (mime-preview-entity-boundary)) + entity situation button-is-visible) + (setq entity (get-text-property (car position) 'mime-view-entity) + situation (get-text-property (car position) 'mime-view-situation) + button-is-visible (mime-view-button-is-visible situation)) + (save-excursion + (delete-region (car position) (cdr position)) + (if (or (eq condition 'hide) + (and (not condition) button-is-visible)) + (mime-display-entity entity + (put-alist '*entity-button + 'invisible situation)) + (mime-display-entity entity + (put-alist '*entity-button + 'visible situation)))))) ;;; @@ quitting ;;; @@ -1351,27 +1964,15 @@ 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)) - ))) + (kill-buffer (current-buffer))))) (defun mime-preview-kill-buffer () (interactive) - (kill-buffer (current-buffer)) - ) + (kill-buffer (current-buffer))) ;;; @ end