X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=1cfcd1c79014fc759d4b477c5de9a0f165843cd2;hb=bd5c2da9b674dbe4d52c456ce996481be2e8e687;hp=74f0a75369d240a909f4366ba12071eb0f2c49b3;hpb=7e5564e1a92f101d4922e82479912d3c2fec3d5b;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 74f0a7536..1cfcd1c79 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -30,7 +30,8 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'mm-inline-partial "mm-partial")) + (autoload 'mm-inline-partial "mm-partial") + (autoload 'mm-inline-external-body "mm-extern")) (defgroup mime-display () "Display of MIME in mail and news articles." @@ -118,6 +119,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) @@ -130,6 +132,7 @@ ("message/delivery-status" mm-inline-text identity) ("message/rfc822" mm-inline-message identity) ("message/partial" mm-inline-partial identity) + ("message/external-body" mm-inline-external-body identity) ("text/.*" mm-inline-text identity) ("audio/wav" mm-inline-audio (lambda (handle) @@ -152,7 +155,7 @@ (defcustom mm-inlined-types '("image/.*" "text/.*" "message/delivery-status" "message/rfc822" - "message/partial" + "message/partial" "message/external-body" "application/emacs-lisp" "application/pgp-signature") "List of media types that are to be displayed inline." :type '(repeat string) @@ -161,7 +164,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) @@ -216,6 +220,45 @@ 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) @@ -311,7 +354,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,13 +402,13 @@ external if displayed external." (let ((cur (current-buffer))) (if (eq method 'mailcap-save-binary-file) (progn - (set-buffer (generate-new-buffer "*mm*")) + (set-buffer (generate-new-buffer " *mm*")) (setq method nil)) (mm-insert-part handle) (let ((win (get-buffer-window cur t))) (when win (select-window win))) - (switch-to-buffer (generate-new-buffer "*mm*"))) + (switch-to-buffer (generate-new-buffer " *mm*"))) (buffer-disable-undo) (mm-set-buffer-file-coding-system mm-binary-coding-system) (insert-buffer-substring cur) @@ -423,7 +466,7 @@ external if displayed external." (progn (call-process shell-file-name nil (setq buffer - (generate-new-buffer "*mm*")) + (generate-new-buffer " *mm*")) nil shell-command-switch (mm-mailcap-command @@ -442,7 +485,7 @@ external if displayed external." (unwind-protect (start-process "*display*" (setq buffer - (generate-new-buffer "*mm*")) + (generate-new-buffer " *mm*")) shell-file-name shell-command-switch (mm-mailcap-command @@ -477,7 +520,7 @@ external if displayed external." (push "<" out) (push (mm-quote-arg file) out))) (mapconcat 'identity (nreverse out) ""))) - + (defun mm-remove-parts (handles) "Remove the displayed MIME parts represented by HANDLES." (if (and (listp handles) @@ -675,10 +718,12 @@ external if displayed external." (or filename name "") (or mm-default-directory default-directory)))) (setq mm-default-directory (file-name-directory file)) - (when (or (not (file-exists-p file)) - (yes-or-no-p (format "File %s already exists; overwrite? " - file))) - (mm-save-part-to-file handle file)))) + (and (or (not (file-exists-p file)) + (yes-or-no-p (format "File %s already exists; overwrite? " + file))) + (progn + (mm-save-part-to-file handle file) + file)))) (defun mm-save-part-to-file (handle file) (mm-with-unibyte-buffer @@ -707,7 +752,9 @@ 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) @@ -825,10 +872,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