X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fmm-decode.el;h=737eb9d1298ea9da802f8c7dc68209bf680a91bc;hb=f992cb0fad1b33b4a97845ecfc183fa8a4d9b91e;hp=7b2300308dcd487dce04908763bb4b49a1c62aef;hpb=78592042164955e6eaae8a42fc99039fa2f1699d;p=elisp%2Fgnus.git- diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 7b23003..737eb9d 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -36,7 +36,8 @@ "Display of MIME in mail and news articles." :link '(custom-manual "(emacs-mime)Customization") :group 'mail - :group 'news) + :group 'news + :group 'multimedia) ;;; Convenience macros. @@ -117,6 +118,7 @@ ("text/x-patch" mm-display-patch-inline (lambda (handle) (locate-library "diff-mode"))) + ("application/emacs-lisp" mm-display-elisp-inline identity) ("text/html" mm-inline-text (lambda (handle) @@ -151,7 +153,7 @@ (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" - "message/partial" + "message/partial" "application/emacs-lisp" "application/pgp-signature") "List of media types that are to be displayed inline." :type '(repeat string) @@ -160,7 +162,8 @@ (defcustom mm-automatic-display '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*" - "message/rfc822" "text/x-patch" "application/pgp-signature") + "message/rfc822" "text/x-patch" "application/pgp-signature" + "application/emacs-lisp") "A list of MIME types to be displayed automatically." :type '(repeat string) :group 'mime-display) @@ -210,6 +213,50 @@ to: (defvar mm-last-shell-command "") (defvar mm-content-id-alist nil) +;; According to RFC2046, in particular, in a digest, the default +;; Content-Type value for a body part is changed from "text/plain" to +;; "message/rfc822". +(defvar mm-dissect-default-type "text/plain") + +(autoload 'mml2015-verify "mml2015") + +(defvar mm-verify-function-alist + '(("application/pgp-signature" . mml2015-verify))) + +(defcustom mm-verify-option nil + "Option of verifying signed parts. +`never', not verify; `always', always verify; +`known', only verify known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'gnus-article) + +(autoload 'mml2015-decrypt "mml2015") + +(defvar mm-decrypt-function-alist + '(("application/pgp-encrypted" . mml2015-decrypt))) + +(defcustom mm-decrypt-option nil + "Option of decrypting signed parts. +`never', not decrypt; `always', always decrypt; +`known', only decrypt known protocols. Otherwise, ask user." + :type '(choice (item always) + (item never) + (item :tag "only known protocols" known) + (item :tag "ask" nil)) + :group 'gnus-article) + +(defvar mm-viewer-completion-map + (let ((map (make-sparse-keymap 'mm-viewer-completion-map))) + (set-keymap-parent map minibuffer-local-completion-map) + map) + "Keymap for input viewer with completion.") + +;; Should we bind other key to minibuffer-complete-word? +(define-key mm-viewer-completion-map " " 'self-insert-command) + ;;; The functions. (defun mm-dissect-buffer (&optional no-strict-mime) @@ -231,7 +278,7 @@ to: (if (or (not ctl) (not (string-match "/" (car ctl)))) (mm-dissect-singlepart - '("text/plain") + (list mm-dissect-default-type) (and cte (intern (downcase (mail-header-remove-whitespace (mail-header-remove-comments cte))))) @@ -245,7 +292,10 @@ to: result (cond ((equal type "multipart") - (cons (car ctl) (mm-dissect-multipart ctl))) + (let ((mm-dissect-default-type (if (equal subtype "digest") + "message/rfc822" + "text/plain"))) + (cons (car ctl) (mm-dissect-multipart ctl)))) (t (mm-dissect-singlepart ctl @@ -287,7 +337,8 @@ to: (if (re-search-backward close-delimiter nil t) (match-beginning 0) (point-max))))) - (while (search-forward boundary end t) + (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) + (while (re-search-forward boundary end t) (goto-char (match-beginning 0)) (when start (save-excursion @@ -301,7 +352,7 @@ to: (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t)) parts))))) - (nreverse parts))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." @@ -359,6 +410,7 @@ external if displayed external." (buffer-disable-undo) (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) + (goto-char (point-min)) (message "Viewing with %s" method) (let ((mm (current-buffer)) (non-viewer (assq 'non-viewer @@ -632,7 +684,7 @@ external if displayed external." (save-excursion (if (member (mm-handle-media-supertype handle) '("text" "message")) (with-temp-buffer - (insert-buffer-substring (mm-handle-buffer handle)) + (insert-buffer-substring (mm-handle-buffer handle)) (mm-decode-content-transfer-encoding (mm-handle-encoding handle) (mm-handle-media-type handle)) @@ -696,9 +748,13 @@ external if displayed external." (methods (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) (mailcap-mime-info type 'all))) - (method (completing-read "Viewer: " methods))) + (method (let ((minibuffer-local-completion-map + mm-viewer-completion-map)) + (completing-read "Viewer: " methods)))) (when (string= method "") (error "No method given")) + (if (string-match "^[^% \t]+$" method) + (setq method (concat method " %s"))) (mm-display-external (copy-sequence handle) method))) (defun mm-preferred-alternative (handles &optional preferred) @@ -755,27 +811,29 @@ external if displayed external." (prog1 (setq spec (ignore-errors - (if (fboundp 'make-glyph) - (cond - ((equal type "xbm") - ;; xbm images require special handling, since - ;; the only way to create glyphs from these - ;; (without a ton of work) is to write them - ;; out to a file, and then create a file - ;; specifier. - (let ((file (make-temp-name - (expand-file-name "emm.xbm" - mm-tmp-directory)))) - (unwind-protect - (progn - (write-region (point-min) (point-max) file) - (make-glyph (list (cons 'x file)))) - (ignore-errors - (delete-file file))))) - (t - (make-glyph - (vector (intern type) :data (buffer-string))))) - (create-image (buffer-string) (intern type) 'data-p)))) + ;; Avoid testing `make-glyph' since W3 may define + ;; a bogus version of it. + (if (fboundp 'create-image) + (create-image (buffer-string) (intern type) 'data-p) + (cond + ((equal type "xbm") + ;; xbm images require special handling, since + ;; the only way to create glyphs from these + ;; (without a ton of work) is to write them + ;; out to a file, and then create a file + ;; specifier. + (let ((file (make-temp-name + (expand-file-name "emm.xbm" + mm-tmp-directory)))) + (unwind-protect + (progn + (write-region (point-min) (point-max) file) + (make-glyph (list (cons 'x file)))) + (ignore-errors + (delete-file file))))) + (t + (make-glyph + (vector (intern type) :data (buffer-string)))))))) (mm-handle-set-cache handle spec)))))) (defun mm-image-fit-p (handle) @@ -787,10 +845,12 @@ external if displayed external." (or mm-inline-large-images (and (< (glyph-width image) (window-pixel-width)) (< (glyph-height image) (window-pixel-height)))) - ;; Let's just inline everything under Emacs 21, since the image - ;; specification there doesn't actually get the width/height - ;; until you render the image. - t))) + (let* ((size (image-size image)) + (w (car size)) + (h (cdr size))) + (or mm-inline-large-images + (and (< h (1- (window-height))) ; Don't include mode line. + (< w (window-width)))))))) (defun mm-valid-image-format-p (format) "Say whether FORMAT can be displayed natively by Emacs." @@ -808,10 +868,102 @@ external if displayed external." (defun mm-valid-and-fit-image-p (format handle) "Say whether FORMAT can be displayed natively and HANDLE fits the window." - (and window-system - (mm-valid-image-format-p format) + (and (mm-valid-image-format-p format) (mm-image-fit-p handle))) +(defun mm-find-part-by-type (handles type &optional notp) + (let (handle) + (while handles + (if (if notp + (not (equal (mm-handle-media-type (car handles)) type)) + (equal (mm-handle-media-type (car handles)) type)) + (setq handle (car handles) + handles nil)) + (setq handles (cdr handles))) + handle)) + +(defun mm-find-raw-part-by-type (ctl type &optional notp) + (goto-char (point-min)) + (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary))) + (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$")) + start + (end (save-excursion + (goto-char (point-max)) + (if (re-search-backward close-delimiter nil t) + (match-beginning 0) + (point-max)))) + result) + (setq boundary (concat (regexp-quote boundary) "[ \t]*$")) + (while (and (not result) + (re-search-forward boundary end t)) + (goto-char (match-beginning 0)) + (when start + (save-excursion + (save-restriction + (narrow-to-region start (point)) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-substring (point-min) (point-max))))))) + (forward-line 2) + (setq start (point))) + (when (and (not result) start) + (save-excursion + (save-restriction + (narrow-to-region start end) + (when (let ((ctl (ignore-errors + (mail-header-parse-content-type + (mail-fetch-field "content-type"))))) + (if notp + (not (equal (car ctl) type)) + (equal (car ctl) type))) + (setq result (buffer-substring (point-min) (point-max))))))) + result)) + +(defun mm-possibly-verify-or-decrypt (parts ctl) + (let ((subtype (cadr (split-string (car ctl) "/"))) + protocol func) + (cond + ((equal subtype "signed") + (setq protocol (mail-content-type-get ctl 'protocol)) + (setq func (cdr (assoc protocol mm-verify-function-alist))) + (if (cond + ((eq mm-verify-option 'never) nil) + ((eq mm-verify-option 'always) t) + ((eq mm-verify-option 'known) func) + (t (y-or-n-p + (format "Verify signed part(protocol=%s)?" protocol)))) + (condition-case err + (save-excursion + (if func + (funcall func parts ctl) + (error (format "Unknown sign protocol(%s)" protocol)))) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (error "Verify failure.")))))) + ((equal subtype "encrypted") + (setq protocol (mail-content-type-get ctl 'protocol)) + (setq func (cdr (assoc protocol mm-decrypt-function-alist))) + (if (cond + ((eq mm-decrypt-option 'never) nil) + ((eq mm-decrypt-option 'always) t) + ((eq mm-decrypt-option 'known) func) + (t (y-or-n-p + (format "Decrypt part (protocol=%s)?" protocol)))) + (condition-case err + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (error (format "Unknown encrypt protocol(%s)" protocol)))) + (error + (unless (y-or-n-p (format "%s, continue?" err)) + (error "Decrypt failure.")))))) + (t nil)) + parts)) + (provide 'mm-decode) ;;; mm-decode.el ends here