: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)
;;;
(set-buffer mime-mother-buffer)
(mime-preview-original-major-mode recursive)
)
- (cdr (assq 'original-major-mode
- (get-text-property (or point (point)) 'mime-view-situation)))))
+ (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
(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))
(defun mime-view-entity-title (entity)
- (or (mime-read-field 'Content-Description entity)
- (mime-read-field 'Subject entity)
+ (or (mime-entity-read-field entity 'Content-Description)
+ (mime-entity-read-field entity 'Subject)
(mime-entity-filename entity)
""))
;;; @@@ 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 eneity
+ ;; 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))))))))
;;; @@@ 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)))
- )))
+ (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))
))
"Condition-tree about how to display entity.")
(ctree-set-calist-strictly
- 'mime-preview-condition '((type . application)(subtype . octet-stream)
+ 'mime-preview-condition '((type . application)(subtype . t)
(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 . 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)))
(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)
"\
(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)))
-
(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)
i (1+ i))
)))
+(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 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))))
+ (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)
+ (entity (get-text-property (point) 'mime-view-entity))
+ (situation (get-text-property (point) 'mime-view-situation))
+ (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))))
+
+
+(defun mime-preview-type ()
+ "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))))))
+
+(defun mime-preview-buttonize ()
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ 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)))))))
+
+(defun mime-preview-unbuttonize ()
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((inhibit-read-only t)
+ 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)))))))))
+
;;; @ acting-condition
;;;
default-situation preview-buffer)
(or preview-buffer
(setq preview-buffer (current-buffer)))
- (let* (e nb ne nhb nbb)
+ (let (e nb ne nhb nbb)
(mime-goto-header-start-point entity)
(in-calist-package 'mime-view)
(or situation
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)))
+ (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.
+ (if (not (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 (and
+ (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))
- (narrow-to-region nb nb)
- (or button-is-invisible
- (if (mime-view-entity-button-visible-p entity)
- (mime-view-insert-entity-button entity)
- ))
- (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)
- ((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)
- )
- (or header-is-visible
- (progn
- (goto-char (point-max))
- (insert "\n")
- ))
- ))
- (setq ne (point-max))
- (widen)
+ (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)
(if children
(if (functionp body-presentation-method)
(funcall body-presentation-method entity situation)
- (mime-display-multipart/mixed 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)
+ (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")
(define-key mime-view-mode-map
"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-p" (function mime-preview-print-current-entity))
(define-key mime-view-mode-map
"a" (function mime-preview-follow-current-entity))
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))
- ;; (raw-buffer (mime-entity-buffer message))
- )
+ (let ((win-conf (current-window-configuration)))
(or preview-buffer
(setq preview-buffer
(concat "*Preview-" (mime-entity-name message) "*")))
- ;; (set-buffer raw-buffer)
- ;; (setq mime-preview-buffer preview-buffer)
+ (or original-major-mode
+ (setq original-major-mode
+ (with-current-buffer (mime-entity-header-buffer message)
+ major-mode)))
(let ((inhibit-read-only t))
(set-buffer (get-buffer-create preview-buffer))
(widen)
(erase-buffer)
- ;; (setq mime-raw-buffer raw-buffer)
(if mother
(setq mime-mother-buffer mother)
)
(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)))
(goto-char (point-min))
(insert ?\n))
(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))
+ (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)
- entity-node-id (cdr entity-node-id))
+ current-entity (mime-entity-parent current-entity))
)
)
- (let ((rest mime-view-following-required-fields-list))
+ (let ((rest mime-view-following-required-fields-list)
+ field-name ret)
(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 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 (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))
+ (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-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)))
;;; @@ quitting
;;;
projects / elisp / semi.git / blobdiff