:group 'mime-view
:type 'file)
+(defcustom mime-preview-move-scroll nil
+ "*Decides whether to scroll when moving to next entity.
+When t, scroll the buffer. Non-nil but not t means scroll when
+the next entity is within `next-screen-context-lines' from top or
+buttom. Nil means don't scroll at all."
+ :group 'mime-view
+ :type '(choice (const :tag "Off" nil)
+ (const :tag "On" t)
+ (sexp :tag "Situation" 1)))
+
+(defcustom mime-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)))
+
+(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)))
;;; @ in raw-buffer (representation space)
;;;
(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
+`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)
(if (and recursive mime-mother-buffer)
(save-excursion
(set-buffer mime-mother-buffer)
- (mime-preview-original-major-mode recursive)
- )
+ (mime-preview-original-major-mode recursive))
(cdr (assq 'major-mode
- (get-text-property (or point (point)) 'mime-view-situation)))))
+ (get-text-property (or point
+ (if (> (point) (buffer-size))
+ (max (1- (point-max)) (point-min))
+ (point)))
+ 'mime-view-situation)))))
;;; @ entity information
(setq rest (or (mime-entity-content-type entity)
(make-mime-content-type 'text 'plain))
situation (cons (car rest) situation)
- rest (cdr rest))
- )
+ 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))
- )
+ rest (cdr rest)))
(while rest
(setq param (car rest))
(or (assoc (car param) situation)
(setq situation (cons (cons 'disposition-type
(mime-content-disposition-type rest))
situation)
- rest (mime-content-disposition-parameters rest))
- ))
+ rest (mime-content-disposition-parameters rest))))
(while rest
(setq param (car rest)
name (car param))
(cons (cons 'encoding (or (mime-entity-encoding entity)
"7bit"))
situation)))
-
- ;; major-mode
- ;; (or (assq 'major-mode situation)
- ;; (setq situation
- ;; (cons (cons 'major-mode
- ;; (with-current-buffer (mime-entity-buffer entity)
- ;; major-mode))
- ;; situation)))
situation))
;; (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
;;;
;;; @@@ predicate function
;;;
+;; #### 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-entity-parent entity)))
- (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)
+(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))
(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 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)))
- )))
- (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
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
(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)))
(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-display-text/plain)))
(ctree-set-calist-strictly
'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 . multipart)(subtype . alternative)
(body . visible)
(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 . 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 . rfc822)
- (body-presentation-method . nil)
- (childrens-situation (header . visible)
- (entity-button . invisible))))
+ '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 . news)
- (body-presentation-method . nil)
- (childrens-situation (header . visible)
- (entity-button . invisible))))
+ '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
(run-hooks 'mime-text-decode-hook)
(goto-char (point-max))
(if (not (eq (char-after (1- (point))) ?\n))
- (insert "\n")
- )
+ (insert "\n"))
(mime-add-url-buttons)
- (run-hooks 'mime-display-text/plain-hook)
- ))
+ (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
(run-hooks 'mime-text-decode-hook)
(let ((beg (point-min)))
(remove-text-properties beg (point-max) '(face nil))
- (richtext-decode beg (point-max))
- )))
+ (richtext-decode beg (point-max)))))
(defun mime-display-text/enriched (entity situation)
(save-restriction
(run-hooks 'mime-text-decode-hook)
(let ((beg (point-min)))
(remove-text-properties beg (point-max) '(face nil))
- (enriched-decode beg (point-max))
- )))
+ (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)
\[[ or click here by mouse button-2. ]]"
"\
\[[ This is message/partial style split message. ]]
-\[[ Please press `v' key in this buffer. ]]"
- ))
+\[[ Please press `v' key in this buffer. ]]"))
(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)
- ))
+ #'mime-preview-play-current-entity)))
(defun mime-display-multipart/mixed (entity situation)
(let ((children (mime-entity-children entity))
- (original-major-mode (cdr (assq 'major-mode situation)))
+ (original-major-mode-cell (assq 'major-mode situation))
(default-situation
(cdr (assq 'childrens-situation situation))))
- (if original-major-mode
+ (if original-major-mode-cell
(setq default-situation
- (cons (cons 'major-mode original-major-mode)
- default-situation))
- )
+ (cons original-major-mode-cell default-situation)))
(while children
(mime-display-entity (car children) nil default-situation)
- (setq children (cdr children))
- )))
-
-(defcustom mime-view-type-subtype-score-alist
- '(((text . enriched) . 3)
- ((text . richtext) . 2)
- ((text . plain) . 1)
- (t . 0))
- "Alist MEDIA-TYPE vs corresponding score.
-MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default."
- :group 'mime-view
- :type '(repeat (cons (choice :tag "Media-Type"
- (cons :tag "Type/Subtype"
- (symbol :tag "Primary-type")
- (symbol :tag "Subtype"))
- (symbol :tag "Type")
- (const :tag "Default" t))
- integer)))
+ (setq children (cdr children)))))
(defun mime-display-multipart/alternative (entity situation)
(let* ((children (mime-entity-children entity))
- (original-major-mode (cdr (assq 'major-mode situation)))
+ (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
+ (if original-major-mode-cell
(setq default-situation
- (cons (cons 'major-mode original-major-mode)
- default-situation))
- )
+ (cons original-major-mode-cell default-situation)))
(setq situations
(mapcar (function
(lambda (child)
mime-view-type-subtype-score-alist)
(assq
t
- mime-view-type-subtype-score-alist)
- ))))
+ mime-view-type-subtype-score-alist)))))
(if (> score max-score)
(setq p i
- max-score score)
- )))
+ max-score score))))
(setq i (1+ i))
- situation)
- ))
+ situation)))
children))
(setq i 0)
(while children
(mime-display-entity child (if (= i p)
situation
(del-alist 'body-presentation-method
- (copy-alist situation))))
- )
+ (copy-alist situation)))))
(setq children (cdr children)
situations (cdr situations)
- i (1+ i))
- )))
+ i (1+ i)))))
+
+(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))
+ 'undecided))
+ 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: ")
+ 'undecided)
+ '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."
+ (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-callback)
+ (mime-preview-toggle-button))))))
+
+(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-callback)
+ (mime-preview-toggle-button))))))
+
;;; @ acting-condition
;;;
(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))
- )
+ (t (setq shared (cons field shared)))))
+ (setq entry (cdr entry)))
(setq shared (nreverse shared))
(ctree-set-calist-with-default
'mime-acting-condition
(ctree-set-calist-with-default
'mime-acting-condition
(append shared
- (list '(mode . "print")(cons 'method (cdr view))))
- ))
- )
- (setq entries (cdr entries))
- )))
+ (list '(mode . "print")(cons 'method (cdr view)))))))
+ (setq entries (cdr entries)))))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . application)(subtype . octet-stream)
(mode . "play")
- (method . mime-detect-content)
- ))
+ (method . mime-detect-content)))
(ctree-set-calist-with-default
'mime-acting-condition
(ctree-set-calist-strictly
'mime-acting-condition
'((type . text)(subtype . x-rot13-47)(mode . "play")
- (method . mime-view-caesar)
- ))
+ (method . mime-view-caesar)))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . text)(subtype . x-rot13-47-48)(mode . "play")
- (method . mime-view-caesar)
- ))
+ (method . mime-view-caesar)))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . message)(subtype . rfc822)(mode . "play")
- (method . mime-view-message/rfc822)
- ))
+ (method . mime-view-message/rfc822)))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . message)(subtype . partial)(mode . "play")
- (method . mime-store-message/partial-piece)
- ))
+ (method . mime-store-message/partial-piece)))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . message)(subtype . external-body)
("access-type" . "anon-ftp")
- (method . mime-view-message/external-anon-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)
- ))
+ (method . mime-view-message/external-url)))
(ctree-set-calist-strictly
'mime-acting-condition
'((type . application)(subtype . octet-stream)
- (method . mime-save-content)
- ))
+ (method . mime-save-content)))
;;; @ quitting method
(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
- (eq (cdr (assq 'entity-button situation)) 'invisible))
- (header-is-visible
- (eq (cdr (assq 'header situation)) 'visible))
- (header-presentation-method
- (or (cdr (assq 'header-presentation-method situation))
- (cdr (assq major-mode mime-header-presentation-method-alist))))
- (body-presentation-method
- (cdr (assq 'body-presentation-method situation)))
- (children (mime-entity-children entity)))
- (set-buffer preview-buffer)
- (setq nb (point))
+ (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)
- (or button-is-invisible
- (if (mime-view-entity-button-visible-p entity)
- (mime-view-insert-entity-button entity)
- ))
+ (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
(run-hooks 'mime-display-header-hook)
(put-text-property nhb (point-max) 'mime-view-entity-header entity)
(goto-char (point-max))
- (insert "\n")
- )
+ (insert "\n"))
(setq nbb (point))
(cond (children)
- ((functionp body-presentation-method)
- (funcall body-presentation-method entity situation)
- )
+ ((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)
- )
- (or header-is-visible
- (progn
- (goto-char (point-max))
- (insert "\n")
- ))
- ))
- (setq ne (point-max))
- (widen)
- (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)
- ))
- )))
-
+ (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
;;;
(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)
- )
- "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 ((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"
(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
(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))
[backspace] (function mime-preview-scroll-down-entity))
(if (functionp default)
(cond ((featurep 'xemacs)
- (set-keymap-default-binding mime-view-mode-map default)
- )
+ (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))
- )
+ 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
(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."
(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)
(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)
(erase-buffer)
(if mother
- (setq mime-mother-buffer 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")
(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)
- ))
+ (search-forward "\n\n" nil t)))
(run-hooks 'mime-view-mode-hook)
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(save-excursion
(set-buffer raw-buffer)
(cdr (or (assq major-mode mime-raw-representation-type-alist)
- (assq t mime-raw-representation-type-alist)))
- )))
+ (assq t mime-raw-representation-type-alist))))))
(if (eq representation-type 'binary)
- (setq representation-type 'buffer)
- )
+ (setq representation-type 'buffer))
(setq preview-buffer (mime-display-message
(mime-open-entity representation-type raw-buffer)
preview-buffer mother default-keymap-or-function))
(let ((m-win (and mother (get-buffer-window mother))))
(if m-win
(set-window-buffer m-win preview-buffer)
- (switch-to-buffer preview-buffer)
- ))))))
+ (switch-to-buffer preview-buffer)))))))
(defun mime-view-mode (&optional mother ctl encoding
raw-buffer preview-buffer
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
(or (assq major-mode mime-raw-representation-type-alist)
(assq t mime-raw-representation-type-alist)))))
(if (eq type 'binary)
- (setq type 'buffer)
- )
+ (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))
- )
+ mime-message-structure ctl)))
(or (mime-entity-encoding mime-message-structure)
- (mime-entity-set-encoding-internal mime-message-structure encoding))
- ))
+ (mime-entity-set-encoding-internal mime-message-structure encoding))))
(mime-display-message mime-message-structure preview-buffer
- mother default-keymap-or-function)
- )
+ mother default-keymap-or-function))
;;; @@ playing
\"extract\" mode. The method is selected from variable
`mime-acting-condition'."
(interactive "P")
- (mime-preview-play-current-entity ignore-examples "extract")
- )
+ (mime-preview-play-current-entity ignore-examples "extract"))
(defun mime-preview-print-current-entity (&optional ignore-examples)
"Print current entity (maybe).
\"print\" mode. The method is selected from variable
`mime-acting-condition'."
(interactive "P")
- (mime-preview-play-current-entity ignore-examples "print")
- )
+ (mime-preview-play-current-entity ignore-examples "print"))
;;; @@ following
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))
- (a-buf (mime-entity-buffer entity))
- 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))
+ (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-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 ((entity-node-id (mime-entity-node-id entity)) ci str)
- (while (progn
- (setq
- str
- (save-excursion
- (set-buffer a-buf)
- (setq ci
- (mime-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))
- ))
- (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
(let (cinfo)
(while (null (setq cinfo
(get-text-property (point) 'mime-view-entity)))
- (backward-char)
- )
+ (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-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)
- )
+ (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.
(interactive)
(while (and (not (eobp))
(null (get-text-property (point) 'mime-view-entity)))
- (forward-char)
- )
+ (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)
- ))
+ (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-preview-over-to-next-method-alist'."
(interactive)
- (or h
- (setq h (1- (window-height)))
- )
- (if (= (point) (point-max))
+ (if (eobp)
(let ((f (assq (mime-preview-original-major-mode)
- mime-preview-over-to-next-method-alist)))
- (if f
- (funcall (cdr f))
- ))
+ 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
+ (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-preview-over-to-previous-method-alist'."
(interactive)
- (or h
- (setq h (1- (window-height)))
- )
- (if (= (point) (point-min))
+ (if (bobp)
(let ((f (assq (mime-preview-original-major-mode)
mime-preview-over-to-previous-method-alist)))
- (if f
- (funcall (cdr f))
- ))
+ (if f
+ (funcall (cdr f))))
(let ((point
(or (previous-single-property-change (point) 'mime-view-entity)
- (point-min))))
- (forward-line (- h))
- (if (< (point) point)
- (goto-char point)
- ))))
-
-(defun mime-preview-next-line-entity ()
- (interactive)
- (mime-preview-scroll-up-entity 1)
- )
-
-(defun mime-preview-previous-line-entity ()
- (interactive)
- (mime-preview-scroll-down-entity 1)
- )
+ (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
+ (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 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
;;;
mime-preview-quitting-method-alist)))
(if r
(funcall (cdr r))
- )))
+ (kill-buffer (current-buffer)))))
(defun mime-preview-kill-buffer ()
(interactive)
- (kill-buffer (current-buffer))
- )
+ (kill-buffer (current-buffer)))
;;; @ end