X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-view.el;h=c97f93d815ad5005e6134cf208a9eb07f7172217;hb=5c2e9049f37c2a97c8c3b04d4c9c68ef86a3560d;hp=c1ea11f73c86464d5311243260d81fada54d7bf7;hpb=0b35cc8d884d0196a210a9721f9d8259867b9f76;p=elisp%2Fsemi.git diff --git a/mime-view.el b/mime-view.el index c1ea11f..c97f93d 100644 --- a/mime-view.el +++ b/mime-view.el @@ -78,6 +78,8 @@ buttom. Nil means don't scroll at all." :group 'mime-view :type '(repeat file)) +(defvar mime-view-automatic-conversion 'undecided) + ;;; @ in raw-buffer (representation space) ;;; @@ -400,7 +402,8 @@ mother-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 " @@ -417,7 +420,7 @@ mother-buffer." (insert "\n;;; " (file-name-nondirectory file) " ends here.\n") - (static-cond + (static-cond ((boundp 'buffer-file-coding-system) (setq buffer-file-coding-system mime-situation-examples-file-coding-system)) @@ -425,7 +428,7 @@ mother-buffer." (setq file-coding-system mime-situation-examples-file-coding-system))) ;; (setq buffer-file-coding-system - ;; mime-situation-examples-file-coding-system) + ;; mime-situation-examples-file-coding-system) (setq buffer-file-name file) (save-buffer))))) @@ -902,19 +905,61 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (car (mime-entity-children entity)))) (original-major-mode-cell (assq 'major-mode situation)) (default-situation (cdr (assq 'childrens-situation situation)))) - (if original-major-mode-cell - (setq default-situation - (cons original-major-mode-cell default-situation))) - (mime-display-entity start nil default-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) - (insert - (decode-mime-charset-string - (mime-decode-string - (mime-entity-body entity) - (mime-view-guess-encoding entity situation)) - (mime-view-guess-charset entity situation) - 'CRLF))) + (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 @@ -923,21 +968,24 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." ;; 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 (get-buffer-create "*fontification*")) + (let ((buffer (generate-new-buffer "*fontification*")) filename) - (save-current-buffer - (set-buffer buffer) - (buffer-disable-undo) - (kill-all-local-variables) - (erase-buffer) - (mime-view-insert-text-content entity situation) - (unwind-protect - (progn + (unwind-protect + (progn + (save-current-buffer + (set-buffer buffer) + (buffer-disable-undo) + (kill-all-local-variables) + (mime-view-insert-text-content entity situation) (if mode (funcall mode) (if (setq filename (mime-entity-filename entity)) - (set-visited-file-name filename)) - (set-auto-mode)) + (unwind-protect + (progn + (setq buffer-file-name filename) + (set-auto-mode)) + (setq buffer-file-name nil)))) + (require 'font-lock) (let ((font-lock-verbose nil)) ;; I find font-lock a bit too verbose. (font-lock-fontify-buffer)) @@ -949,8 +997,8 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (set-extent-property ext 'duplicable t) nil) nil nil nil nil nil 'text-prop))) - (set-visited-file-name nil))) - (insert-buffer-substring buffer))) + (insert-buffer-substring buffer)) + (kill-buffer buffer)))) (defun mime-display-application/emacs-lisp (entity situation) (save-restriction @@ -1176,7 +1224,7 @@ MEDIA-TYPE must be (TYPE . SUBTYPE), TYPE or t. t means default." (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) @@ -1418,15 +1466,19 @@ button-2 Move to point under the mouse cursor ;;; @@ 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 @@ -1443,9 +1495,8 @@ button-2 Move to point under the mouse cursor (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 @@ -1453,12 +1504,14 @@ button-2 Move to point under the mouse cursor (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))) @@ -1494,13 +1547,13 @@ It decodes current entity to call internal or external method as 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 @@ -1508,7 +1561,7 @@ It calls following-method selected from variable (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 @@ -1521,7 +1574,8 @@ It calls following-method selected from variable (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))) @@ -1558,9 +1612,8 @@ It calls following-method selected from variable (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 @@ -1755,14 +1808,14 @@ If LINES is negative, scroll up LINES lines." (lambda (sym) (list (symbol-name sym))) (mime-charset-list)) - #'mime-charset-p t + 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 encoding charset) (setq p-beg (aref situation 0)