;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Code:
(require 'calist)
(require 'alist)
(require 'mime-conf)
+(require 'mcharset)
+
+(eval-when-compile (require 'static))
;;; @ version
:group 'mime-view
:type '(repeat file))
+(defvar mime-view-automatic-conversion 'undecided)
+
;;; @ in raw-buffer (representation space)
;;;
(with-temp-buffer
(insert-file-contents file)
(setq mime-situation-examples-file-coding-system
- (and (boundp 'buffer-file-coding-system)
- buffer-file-coding-system)
- ;; (static-cond
- ;; ((boundp 'buffer-file-coding-system)
- ;; (symbol-value 'buffer-file-coding-system))
- ;; ((boundp 'file-coding-system)
- ;; (symbol-value 'file-coding-system))
- ;; (t nil))
+ (static-cond
+ ((boundp 'buffer-file-coding-system)
+ (symbol-value 'buffer-file-coding-system))
+ ((boundp 'file-coding-system)
+ (symbol-value 'file-coding-system))
+ (t nil))
+ ;; (and (boundp 'buffer-file-coding-system)
+ ;; buffer-file-coding-system)
)
(condition-case error
(eval-buffer)
(defun mime-save-situation-examples ()
(if (or mime-preview-situation-example-list
mime-acting-situation-example-list)
- (let ((file mime-situation-examples-file))
+ (let ((file mime-situation-examples-file)
+ print-length print-level)
(with-temp-buffer
(insert ";;; " (file-name-nondirectory file) "\n")
(insert "\n;; This file is generated automatically by "
(insert "\n;;; "
(file-name-nondirectory file)
" ends here.\n")
- (setq buffer-file-coding-system
- mime-situation-examples-file-coding-system)
- ;; (static-cond
- ;; ((boundp 'buffer-file-coding-system)
- ;; (setq buffer-file-coding-system
- ;; mime-situation-examples-file-coding-system))
- ;; ((boundp 'file-coding-system)
- ;; (setq file-coding-system
- ;; mime-situation-examples-file-coding-system)))
+ (static-cond
+ ((boundp 'buffer-file-coding-system)
+ (setq buffer-file-coding-system
+ mime-situation-examples-file-coding-system))
+ ((boundp 'file-coding-system)
+ (setq file-coding-system
+ mime-situation-examples-file-coding-system)))
+ ;; (setq buffer-file-coding-system
+ ;; mime-situation-examples-file-coding-system)
(setq buffer-file-name file)
(save-buffer)))))
(autoload 'fill-flowed "flow-fill")
+(defvar mime-preview-inline-fontify t
+ "If non-nil, fontify the inline part.")
+
(ctree-set-calist-strictly
'mime-preview-condition
'((type . nil)
(ctree-set-calist-strictly
'mime-preview-condition
+ '((type . application)(subtype . emacs-lisp)
+ (body . visible)
+ (body-presentation-method . mime-display-application/emacs-lisp)))
+
+(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 . multipart)(subtype . related)
+ (body . visible)
+ (body-presentation-method . mime-display-multipart/related)))
+
+(ctree-set-calist-strictly
+ 'mime-preview-condition
'((type . multipart)(subtype . t)
(body . visible)
(body-presentation-method . mime-display-multipart/mixed)))
(save-restriction
(narrow-to-region (point-max)(point-max))
(condition-case nil
- (mime-insert-text-content entity)
+ (if (and mime-preview-inline-fontify
+ (mime-entity-filename entity)) ;should be an attachment.
+ (mime-view-insert-fontified-text-content entity situation)
+ (mime-view-insert-text-content entity situation))
(error (progn
(message "Can't decode current entity.")
(sit-for 1))))
(defun mime-display-text/richtext (entity situation)
(save-restriction
(narrow-to-region (point-max)(point-max))
- (mime-insert-text-content entity)
+ (mime-view-insert-text-content entity situation)
(run-hooks 'mime-text-decode-hook)
(let ((beg (point-min)))
(remove-text-properties beg (point-max) '(face nil))
(defun mime-display-text/enriched (entity situation)
(save-restriction
(narrow-to-region (point-max)(point-max))
- (mime-insert-text-content entity)
+ (mime-view-insert-text-content entity situation)
(run-hooks 'mime-text-decode-hook)
(let ((beg (point-min)))
(remove-text-properties beg (point-max) '(face nil))
situations (cdr situations)
i (1+ i)))))
+(defun mime-display-multipart/related (entity situation)
+ (let* ((param-start (mime-parse-msg-id
+ (std11-lexical-analyze
+ (cdr (assoc "start"
+ (mime-content-type-parameters
+ (mime-entity-content-type entity)))))))
+ (start (or (and param-start (mime-find-entity-from-content-id
+ param-start
+ entity))
+ (car (mime-entity-children entity))))
+ (original-major-mode-cell (assq 'major-mode situation))
+ (default-situation (cdr (assq 'childrens-situation situation))))
+ (when start
+ (if original-major-mode-cell
+ (setq default-situation
+ (cons original-major-mode-cell default-situation)))
+ (mime-display-entity start nil default-situation))))
+
+(defun mime-view-entity-content (entity situation)
+ (mime-decode-string
+ (mime-entity-body entity)
+ (mime-view-guess-encoding entity situation)))
+
+(defun mime-view-insert-text-content (entity situation)
+ (let (compression-info)
+ (cond
+ ((and (mime-entity-filename entity)
+ (featurep 'jka-compr)
+ (jka-compr-installed-p)
+ (setq compression-info (jka-compr-get-compression-info
+ (mime-entity-filename entity))))
+ (insert
+ (mime-view-filter-text-content
+ (mime-view-entity-content entity situation)
+ (jka-compr-info-uncompress-program compression-info)
+ (jka-compr-info-uncompress-args compression-info))))
+ ((or (assq '*encoding situation) ;should be specified by user
+ (assq '*charset situation)) ;should be specified by user
+ (insert
+ (decode-mime-charset-string
+ (mime-view-entity-content entity situation)
+ (mime-view-guess-charset entity situation)
+ 'CRLF)))
+ (t
+ (mime-insert-text-content entity)))))
+
+;;; stolen (and renamed) from `mime-display-gzipped' of EMY 1.13.
+(defun mime-view-filter-text-content (content program args)
+ (with-temp-buffer
+ (static-cond
+ ((featurep 'xemacs)
+ (insert content)
+ (apply #'binary-to-text-funcall
+ mime-view-automatic-conversion
+ #'call-process-region (point-min)(point-max)
+ program t t args))
+ (t
+ (if (not (multibyte-string-p content))
+ (set-buffer-multibyte nil))
+ (insert content)
+ (apply #'binary-funcall
+ #'call-process-region (point-min)(point-max)
+ program t t args)
+ (set-buffer-multibyte t)
+ (decode-coding-region (point-min)(point-max)
+ mime-view-automatic-conversion)))
+ (buffer-string)))
+
+;;; stolen (and renamed) from mm-view.el.
+(defun mime-view-insert-fontified-text-content (entity situation
+ &optional mode)
+ ;; XEmacs @#$@ version of font-lock refuses to fully turn itself
+ ;; on for buffers whose name begins with " ". That's why we use
+ ;; save-current-buffer/get-buffer-create rather than
+ ;; with-temp-buffer.
+ (let ((buffer (generate-new-buffer "*fontification*"))
+ filename)
+ (unwind-protect
+ (progn
+ (save-current-buffer
+ (set-buffer buffer)
+ (buffer-disable-undo)
+ (kill-all-local-variables)
+ (mime-view-insert-text-content entity situation)
+ (require 'font-lock)
+ (let ((font-lock-maximum-size nil)
+ ;; Disable support modes, e.g., jit-lock, lazy-lock, etc.
+ (font-lock-mode-hook nil)
+ (font-lock-support-mode nil)
+ ;; I find font-lock a bit too verbose.
+ (font-lock-verbose nil))
+ (cond (mode
+ (funcall mode))
+ ((setq filename (mime-entity-filename entity))
+ (let ((buffer-file-name
+ (expand-file-name (file-name-nondirectory filename)
+ temporary-file-directory)))
+ (set-auto-mode))))
+ ;; The mode function might have already turned on font-lock.
+ (unless (symbol-value 'font-lock-mode)
+ (font-lock-fontify-buffer)))
+ ;; By default, XEmacs font-lock uses non-duplicable text
+ ;; properties. This code forces all the text properties
+ ;; to be copied along with the text.
+ (static-when (fboundp 'extent-list)
+ (map-extents (lambda (ext ignored)
+ (set-extent-property ext 'duplicable t)
+ nil)
+ nil nil nil nil nil 'text-prop)))
+ (insert-buffer-substring buffer))
+ (kill-buffer buffer))))
+
+(defun mime-display-application/emacs-lisp (entity situation)
+ (save-restriction
+ (narrow-to-region (point-max)(point-max))
+ (mime-view-insert-fontified-text-content entity situation 'emacs-lisp-mode)
+ (run-hooks 'mime-text-decode-hook 'mime-display-text/plain-hook)))
+
;;; @ acting-condition
;;;
(when (boundp 'widget-keymap)
(set-keymap-parent (current-local-map) widget-keymap)))
-(add-hook 'mime-view-define-keymap-hook 'mime-view-maybe-inherit-widget-keymap)
+(add-hook 'mime-view-mode-hook 'mime-view-maybe-inherit-widget-keymap)
(defun mime-view-define-keymap (&optional default)
(let ((mime-view-mode-map (if (keymapp default)
;;; @@ utility
;;;
-(defun mime-preview-find-boundary-info (&optional get-mother)
+(defun mime-preview-find-boundary-info (&optional with-children)
+ "Return boundary information of current part.
+If WITH-CHILDREN, refer boundary surrounding current part and its branches."
(let (entity
p-beg p-end
entity-node-id len)
- (while (null (setq entity
- (get-text-property (point) 'mime-view-entity)))
+ (while (and
+ (null (setq entity
+ (get-text-property (point) 'mime-view-entity)))
+ (> (point) (point-min)))
(backward-char))
(setq p-beg (previous-single-property-change (point) 'mime-view-entity))
- (setq entity-node-id (mime-entity-node-id entity))
+ (setq entity-node-id (and entity (mime-entity-node-id entity)))
(setq len (length entity-node-id))
(cond ((null p-beg)
(setq p-beg
(setq p-end (point-max)))
((null entity-node-id)
(setq p-end (point-max)))
- (get-mother
+ (with-children
(save-excursion
- (goto-char p-end)
(catch 'tag
(let (e i)
(while (setq e
(point) 'mime-view-entity))
(goto-char e)
(let ((rc (mime-entity-node-id
- (get-text-property (1- (point))
+ (get-text-property (point)
'mime-view-entity))))
(or (and (>= (setq i (- (length rc) len)) 0)
(equal entity-node-id (nthcdr i rc)))
(throw 'tag nil)))
- (setq p-end e)))
+ (setq p-end (or (next-single-property-change
+ (point) 'mime-view-entity)
+ (point-max)))))
(setq p-end (point-max))))))
(vector p-beg p-end entity)))
It calls following-method selected from variable
`mime-preview-following-method-alist'."
(interactive)
- (let ((entity (mime-preview-find-boundary-info t))
- p-beg p-end
- pb-beg)
- (setq p-beg (aref entity 0)
- p-end (aref entity 1)
- entity (aref entity 2))
- (if (get-text-property p-beg 'mime-view-entity-body)
+ (let* ((boundary-info (mime-preview-find-boundary-info t))
+ (p-beg (aref boundary-info 0))
+ (p-end (aref boundary-info 1))
+ (entity (aref boundary-info 2))
+ pb-beg)
+ (if (or (get-text-property p-beg 'mime-view-entity-body)
+ (null entity))
(setq pb-beg p-beg)
(setq pb-beg
(next-single-property-change
(or (next-single-property-change p-beg 'mime-view-entity)
p-end))))
(let* ((mode (mime-preview-original-major-mode 'recursive))
- (entity-node-id (mime-entity-node-id entity))
+ (entity-node-id (and entity (mime-entity-node-id entity)))
(new-name
(format "%s-%s" (buffer-name) (reverse entity-node-id)))
new-buf
(insert-buffer-substring the-buf pb-beg p-end)
(goto-char (point-min))
(let ((current-entity
- (if (and (eq (mime-entity-media-type entity) 'message)
+ (if (and entity
+ (eq (mime-entity-media-type entity) 'message)
(eq (mime-entity-media-subtype entity) 'rfc822))
(car (mime-entity-children entity))
entity)))
(if (functionp f)
(funcall f new-buf)
(message
- (format
- "Sorry, following method for %s is not implemented yet."
- mode)))))))
+ "Sorry, following method for %s is not implemented yet."
+ mode))))))
;;; @@ moving
;;; @@ display
;;;
+(defun mime-view-guess-encoding (entity situation)
+ (or (cdr (assq '*encoding situation))
+ (cdr (assq 'encoding situation))
+ (mime-entity-encoding entity)
+ "7bit"))
+
+(defun mime-view-read-encoding (entity situation)
+ (let* ((default-encoding
+ (mime-view-guess-encoding entity situation))
+ (encoding
+ (completing-read
+ "Content Transfer Encoding: "
+ (mime-encoding-alist) nil t default-encoding)))
+ (unless (or (string= encoding "")
+ (string= encoding default-encoding))
+ encoding)))
+
+(defun mime-view-guess-charset (entity situation)
+ (or (static-if (fboundp 'coding-system-to-mime-charset)
+ ;; might be overridden by `universal-coding-system-argument'.
+ (and coding-system-for-read
+ (coding-system-to-mime-charset coding-system-for-read)))
+ (cdr (assq '*charset situation))
+ (cdr (assq 'charset situation))
+ (let ((charset (cdr (assoc "charset" (mime-entity-parameters entity)))))
+ (if charset
+ (intern (downcase charset))))
+ default-mime-charset))
+
+(defun mime-view-read-charset (entity situation)
+ (static-if (featurep 'mule)
+ (let* ((default-charset
+ (mime-view-guess-charset entity situation))
+ (charset
+ (intern (completing-read "MIME-charset: "
+ (mapcar
+ (lambda (sym)
+ (list (symbol-name sym)))
+ (mime-charset-list))
+ nil t
+ (symbol-name default-charset)))))
+ (unless (eq charset default-charset)
+ charset))
+ default-charset))
+
(defun mime-preview-toggle-display (type &optional display)
- (let ((situation (mime-preview-find-boundary-info))
+ (let ((situation (mime-preview-find-boundary-info t))
(sym (intern (concat "*" (symbol-name type))))
- entity p-beg p-end)
+ entity p-beg p-end encoding charset)
(setq p-beg (aref situation 0)
p-end (aref situation 1)
entity (aref situation 2)
(display)
(t
(setq display
- (eq (cdr (or (assq sym situation)
- (assq type situation)))
- 'invisible))))
+ (memq (cdr (or (assq sym situation)
+ (assq type situation)))
+ '(nil invisible)))))
(setq situation (put-alist sym (if display
'visible
'invisible)
situation))
+ (when (and current-prefix-arg
+ (eq (cdr (assq sym situation)) 'visible))
+ (if (setq encoding (mime-view-read-encoding entity situation))
+ (setq situation (put-alist '*encoding encoding situation)))
+ (if (setq charset (mime-view-read-charset entity situation))
+ (setq situation (put-alist '*charset charset situation))))
(save-excursion
(let ((inhibit-read-only t))
(delete-region p-beg p-end)
projects / elisp / semi.git / blobdiff