(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."
+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)
'((mime-show-message-mode . binary)
(mime-temp-message-mode . binary)
(t . cooked))
- "Alist of major-mode vs. representation-type of mime-raw-buffer.
+ "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
+`major-mode' or t. t means default. REPRESENTATION-TYPE must be
`binary' or `cooked'.")
;; (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)
;; (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
;;;
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))))))))
+ (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
;;;
(body-presentation-method . mime-display-multipart/alternative)))
(ctree-set-calist-strictly
- 'mime-preview-condition '((type . message)(subtype . partial)
- (body-presentation-method
- . mime-display-message/partial-button)))
+ '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 . rfc822)
- (body-presentation-method . nil)
- (childrens-situation (header . visible)
- (entity-button . invisible))))
+ '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 . news)
- (body-presentation-method . nil)
- (childrens-situation (header . visible)
- (entity-button . invisible))))
+ '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
(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 (mime-entity-content entity)
+ (cdr (assq 'encoding situation)))
+ (or (cdr (assq 'coding situation))
+ 'binary)))))
+
(defun mime-display-text/richtext (entity situation)
(save-restriction
(narrow-to-region (point-max)(point-max))
i (1+ i)))))
(defun mime-display-detect-application/octet-stream (entity situation)
- "Detect unknown part and display it inline.
+ "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-text/plain entity situation)))
(defun mime-display-gzipped (entity situation)
- "Ungzip gzipped part and display"
+ "Ungzip gzipped part and display."
(insert
- (with-temp-buffer
- (insert (mime-entity-content entity))
- (as-binary-process
- (call-process-region (point-min) (point-max) "gzip" t t
- nil "-cd"))
- (buffer-string (point-min) (point-max))))
- t)
+ (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))
+ 'undecided))
+ t)
(defun mime-preview-inline ()
- "View part as text without code conversion"
+ "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 end)
+ start)
(when (and entity
(not (get-text-property (point) 'mime-view-entity-header))
(not (memq (mime-entity-media-type entity)
With prefix, it prompts for coding-system."
(interactive "P")
(let ((inhibit-read-only t)
- (entity (get-text-property (point) 'mime-view-entity))
- (situation (get-text-property (point) 'mime-view-situation))
+ (mime-view-force-inline-types t)
+ (position (mime-preview-entity-boundary))
(coding (if ask-coding
(or (read-coding-system "Coding system: ")
'undecided)
- 'undecided)))
- (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 (decode-coding-string (mime-entity-content entity) coding))
- (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))))
-
+ 'undecided))
+ (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"
+ "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))
- (mime-view-force-inline-types t)
- start end)
- (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))))
- (save-excursion
- (save-restriction
- (narrow-to-region (point) (point))
- (mime-display-entity entity (if (eq (assq 'body situation)
- 'invisible)
- situation
- (put-alist 'body 'visible
- situation))))
- (if (and (bolp) (eolp))
- (delete-char 1))))))
+ (mime-preview-toggle-content t))
(defun mime-preview-buttonize ()
(interactive)
(save-excursion
(goto-char (point-min))
- (let ((inhibit-read-only t)
- point)
+ (let (point)
(while (setq point (next-single-property-change
(point) 'mime-view-entity))
(goto-char point)
(unless (get-text-property (point) 'mime-button-callback)
- (mime-view-insert-entity-button
- (get-text-property (point) 'mime-view-entity)))))))
+ (mime-preview-toggle-button))))))
(defun mime-preview-unbuttonize ()
(interactive)
(save-excursion
(goto-char (point-min))
- (let ((inhibit-read-only t)
- point)
+ (let (point)
(while (setq point (next-single-property-change
(point) 'mime-view-entity))
(goto-char point)
- (if (get-text-property (point) 'mime-button-callback)
- (delete-region (point) (save-excursion
- (goto-char
- (next-single-property-change
- (point) 'mime-button-callback)))))))))
+ (when (get-text-property (point) 'mime-button-callback)
+ (mime-preview-toggle-button))))))
;;; @ acting-condition
(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-preview-over-to-previous-method-alist nil
- "Alist of major-mode vs. over-to-previous-method of mime-view.")
+ "Alist of `major-mode' vs. over-to-previous-method of mime-view.")
(defvar mime-preview-over-to-next-method-alist nil
- "Alist of major-mode vs. over-to-next-method of mime-view.")
+ "Alist of `major-mode' vs. over-to-next-method of mime-view.")
;;; @ following method
;;;
(defvar mime-preview-following-method-alist nil
- "Alist of major-mode vs. following-method of mime-view.")
+ "Alist of `major-mode' vs. following-method of mime-view.")
(defvar mime-view-following-required-fields-list
'("From"))
(defun mime-display-entity (entity &optional situation
default-situation preview-buffer)
+ "Display mime-entity ENTITY."
(or preview-buffer
(setq preview-buffer (current-buffer)))
- (let (e nb ne nhb nbb)
- (mime-goto-header-start-point entity)
- (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-invisible
- (or (eq (cdr (assq 'entity-button situation)) 'invisible)
- (not (mime-view-entity-button-visible-p entity))))
- (header-is-visible
- (eq (cdr (assq 'header situation)) 'visible))
- (header-presentation-method
- (or (cdr (assq 'header-presentation-method situation))
- (cdr (assq (cdr (assq 'major-mode situation))
- mime-header-presentation-method-alist))))
- (body-is-visible
- (eq (cdr (assq 'body situation)) 'visible))
- (body-presentation-method
- (cdr (assq 'body-presentation-method situation)))
- (children (mime-entity-children entity)))
- ;; 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
- (setq header-is-visible nil
- body-is-visible nil))
- (set-buffer preview-buffer)
- (setq nb (point))
- (save-restriction
- (narrow-to-region nb nb)
- (or button-is-invisible
- (if (mime-view-entity-button-visible-p entity)
- (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
- (goto-char (point-max))
- (mime-view-insert-entity-button entity
- ;; work around composite type
- (not (or children
- body-is-visible))))
- (or header-is-visible
- (progn
- (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 children
- (if (functionp body-presentation-method)
- (funcall body-presentation-method entity situation)
- (mime-display-multipart/mixed entity situation))))))
-
+ (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
+ (setq header-is-visible nil
+ body-is-visible nil)
+ (put-alist 'header 'invisible situation)
+ (put-alist 'body 'invisible situation))
+ (set-buffer preview-buffer)
+ (setq nb (point))
+ (save-restriction
+ (narrow-to-region nb nb)
+ (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 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
+ ;; 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
;;;
(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")
+ "Menu for MIME Viewer.")
(cond ((featurep 'xemacs)
(defvar mime-view-xemacs-popup-menu
(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
"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))
(setq preview-buffer
(concat "*Preview-" (mime-entity-name message) "*")))
(or original-major-mode
- (setq original-major-mode
- (with-current-buffer (mime-entity-header-buffer message)
- major-mode)))
+ (setq original-major-mode major-mode))
(let ((inhibit-read-only t))
(set-buffer (get-buffer-create preview-buffer))
(widen)
a Followup to current content.
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)
(unless mime-view-redisplay
(save-excursion
It calls following-method selected from variable
`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
- ph-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))))))
- (setq ph-end
- (previous-single-property-change p-end 'mime-view-entity-header))
- (if (or (null ph-end)
- (< ph-end p-beg))
- (setq ph-end p-beg))
- (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)
- (insert-buffer-substring the-buf ph-end p-end)
- (when (= ph-end p-beg)
- (goto-char (point-min))
- (insert ?\n))
+ (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-callback
+ 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 ((current-entity
- (if (and (eq (mime-entity-media-type entity) 'message)
- (eq (mime-entity-media-subtype entity) 'rfc822))
- (mime-entity-children entity)
- entity))
- str)
- (while (and current-entity
- (progn
- (setq str
- (with-current-buffer
- (mime-entity-header-buffer current-entity)
- (save-restriction
- (narrow-to-region
- (mime-entity-header-start-point
- current-entity)
- (mime-entity-header-end-point
- current-entity))
- (std11-header-string-except
- (concat
- "^"
- (apply (function regexp-or) fields)
- ":") ""))))
- (if (and (eq (mime-entity-media-type
- current-entity) 'message)
- (eq (mime-entity-media-subtype
- current-entity) 'rfc822))
- nil
- (if str
- (insert str))
- 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)
- (setq ret
- (when mime-mother-buffer
- (set-buffer mime-mother-buffer)
- (mime-entity-fetch-field
- (get-text-property (point)
- 'mime-view-entity)
- field-name))))
- (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))))))))
+ (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
(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 show)
+ "Toggle display of entity button.
+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 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 show (not button-is-visible))
+ (mime-display-entity entity
+ (put-alist '*entity-button
+ 'visible situation))
+ (mime-display-entity entity
+ (put-alist '*entity-button
+ 'invisible situation))))))
+
;;; @@ quitting
;;;
(let ((r (assq (mime-preview-original-major-mode)
mime-preview-quitting-method-alist)))
(if r
- (funcall (cdr r)))))
+ (funcall (cdr r))
+ (kill-buffer (current-buffer)))))
(defun mime-preview-kill-buffer ()
(interactive)