From 9c2c16020432e48be5ed5a551fa556379af46f37 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Tue, 7 Nov 2000 22:22:50 +0000 Subject: [PATCH] Synch with Gnus. --- lisp/ChangeLog | 14 +++++ lisp/gnus-art.el | 88 ++++++++++++++++++++++++-- lisp/mm-decode.el | 47 +++++++++----- lisp/mm-uu.el | 42 ++++++------- lisp/mml2015.el | 182 +++++++++++++++++++++++++++++++++++------------------ texi/ChangeLog | 4 ++ texi/gnus.texi | 2 +- 7 files changed, 273 insertions(+), 106 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a92b3bf..ff59a59 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,17 @@ +2000-11-07 14:33:19 ShengHuo ZHU + + * gnus-art.el (gnus-mime-display-part): Show MIME security button. + (gnus-insert-mime-security-button): New function. + * mm-decode.el (mm-possibly-verify-or-decrypt): Add security info. + * mml2015.el: Add security info when verify or decrypt. + * mm-uu.el (mm-uu-pgp-signed-extract): Use multipart. + (mm-uu-pgp-encrypted-extract): Ditto. + +2000-11-07 08:49:36 ShengHuo ZHU + + * mm-decode.el (mm-display-parts): New function. + * gnus-art.el (gnus-mime-view-all-parts): Use it. Remove parts first. + 2000-02-02 Alexandre Oliva * gnus-mlspl.el: Documentation tweaks. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 84fa1bd..acf82c9 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -3352,11 +3352,14 @@ value of the variable `gnus-show-mime' is non-nil." (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) - (if (stringp (car handles)) - (gnus-mime-view-all-parts (cdr handles)) - (mapcar 'mm-display-part handles))))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) + (mm-remove-parts handles) + (goto-char (point-min)) + (or (search-forward "\n\n") (goto-char (point-max))) + (let (buffer-read-only) + (delete-region (point) (point-max))) + (mm-display-parts handles)))) (defun gnus-mime-save-part-and-strip () "Save the MIME part under point then replace it with an external body." @@ -3857,10 +3860,12 @@ In no internal viewer is available, use an external viewer." ((equal (car handle) "multipart/signed") (or (memq 'signed gnus-article-wash-types) (push 'signed gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) (gnus-mime-display-mixed (cdr handle))) ((equal (car handle) "multipart/encrypted") (or (memq 'encrypted gnus-article-wash-types) (push 'encrypted gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) (gnus-mime-display-mixed (cdr handle))) (t (gnus-mime-display-mixed (cdr handle))))) @@ -5529,6 +5534,79 @@ For example: (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current)))))))) +(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info") + +(defvar gnus-mime-security-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?i gnus-tmp-info ?s))) + +(defvar gnus-mime-security-button-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map gnus-article-mode-map) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map "\r" 'gnus-article-press-button) + map)) + +(defvar gnus-mime-security-details-buffer nil) + +(defun gnus-mime-security-show-details (handle) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (if details + (progn + (if (gnus-buffer-live-p gnus-mime-security-details-buffer) + (with-current-buffer gnus-mime-security-details-buffer + (erase-buffer) + t) + (setq gnus-mime-security-details-buffer + (gnus-get-buffer-create "*MIME Security Details*"))) + (with-current-buffer gnus-mime-security-details-buffer + (insert details)) + (pop-to-buffer gnus-mime-security-details-buffer)) + (gnus-message 5 "No details.")))) + +(defun gnus-insert-mime-security-button (handle &optional displayed) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (gnus-tmp-type + (concat + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted"))) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + b e) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (gnus-eval-format + gnus-mime-security-button-line-format + gnus-mime-security-button-line-format-alist + `(local-map ,gnus-mime-security-button-map + keymap ,gnus-mime-security-button-map + gnus-callback gnus-mime-security-show-details + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-security-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (if (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: show detail" + (aref gnus-mouse-2 0)))))) + ;;; @ for mime-view ;;; diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 344d05e..d2f9257 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -418,6 +418,16 @@ The original alist is not modified. See also `destructive-alist-to-plist'." (insert-buffer-substring obuf beg) (current-buffer)))) +(defun mm-display-parts (handle &optional no-default) + (if (stringp (car handle)) + (mapcar 'mm-display-parts (cdr handle)) + (if (bufferp (car handle)) + (save-restriction + (narrow-to-region (point) (point)) + (mm-display-part handle) + (goto-char (point-max))) + (mapcar 'mm-display-parts handle)))) + (defun mm-display-part (handle &optional no-default) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; @@ -984,8 +994,17 @@ If RECURSIVE, search recursively." (setq result (buffer-substring (point-min) (point-max))))))) result)) +(defvar mm-security-handle nil) + +(defsubst mm-set-handle-multipart-parameter (handle parameter value) + ;; HANDLE could be a CTL. + (if handle + (put-text-property 0 (length (car handle)) parameter value + (car handle)))) + (defun mm-possibly-verify-or-decrypt (parts ctl) (let ((subtype (cadr (split-string (car ctl) "/"))) + (mm-security-handle ctl) ;; (car CTL) is the type. protocol func functest) (cond ((equal subtype "signed") @@ -1014,14 +1033,12 @@ If RECURSIVE, search recursively." (format "Verify signed (%s) part? " (or (nth 2 (assoc protocol mm-verify-function-alist)) (format "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.")))))) + (save-excursion + (if func + (funcall func parts ctl) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown sign protocol (%s)" protocol)))))) ((equal subtype "encrypted") (unless (setq protocol (mail-content-type-get ctl 'protocol)) ;; The message is broken. @@ -1046,14 +1063,12 @@ If RECURSIVE, search recursively." (format "Decrypt (%s) part? " (or (nth 2 (assoc protocol mm-decrypt-function-alist)) (format "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.")))))) + (save-excursion + (if func + (setq parts (funcall func parts ctl)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (format "Unknown encrypt protocol (%s)" protocol)))))) (t nil)) parts)) diff --git a/lisp/mm-uu.el b/lisp/mm-uu.el index 47aa032..46fc4f1 100644 --- a/lisp/mm-uu.el +++ b/lisp/mm-uu.el @@ -257,23 +257,22 @@ To disable dissecting shar codes, for instance, add (t (y-or-n-p "Verify pgp signed part?"))))) (defun mm-uu-pgp-signed-extract () - (or (memq 'signed gnus-article-wash-types) - (push 'signed gnus-article-wash-types)) - (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (let ((buf (mm-uu-copy-to-buffer start-point end-point)) + (mm-security-handle (list (format "multipart/signed")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/pgp-signature") (with-current-buffer buf - (condition-case err - (funcall (mml2015-clear-verify-function)) - (error - (unless (y-or-n-p (format "%s, continue?" err)) - (kill-buffer buf) - (error "Verify failure.")))) + (funcall (mml2015-clear-verify-function)) (goto-char (point-min)) (if (search-forward "\n\n" nil t) (delete-region (point-min) (point))) (if (re-search-forward mm-uu-pgp-beginning-signature nil t) (delete-region (match-beginning 0) (point-max)))) - (mm-make-handle buf - '("text/plain" (charset . gnus-decoded))))) + (setcdr mm-security-handle + (list + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + mm-security-handle)) (defun mm-uu-pgp-encrypted-test () (and @@ -286,18 +285,17 @@ To disable dissecting shar codes, for instance, add (t (y-or-n-p "Decrypt pgp encrypted part?"))))) (defun mm-uu-pgp-encrypted-extract () - (or (memq 'encrypted gnus-article-wash-types) - (push 'encrypted gnus-article-wash-types)) - (let ((buf (mm-uu-copy-to-buffer start-point end-point))) + (let ((buf (mm-uu-copy-to-buffer start-point end-point)) + (mm-security-handle (list (format "multipart/encrypted")))) + (mm-set-handle-multipart-parameter + mm-security-handle 'protocol "application/pgp-encrypted") (with-current-buffer buf - (condition-case err - (funcall (mml2015-clear-decrypt-function)) - (error - (unless (y-or-n-p (format "%s, continue?" err)) - (kill-buffer buf) - (error "Decrypt failure."))))) - (mm-make-handle buf - '("text/plain" (charset . gnus-decoded))))) + (funcall (mml2015-clear-decrypt-function))) + (setcdr mm-security-handle + (list + (mm-make-handle buf + '("text/plain" (charset . gnus-decoded))))) + mm-security-handle)) (defun mm-uu-gpg-key-skip-to-last () (let ((point (point)) diff --git a/lisp/mml2015.el b/lisp/mml2015.el index dfd62be..973d50f 100644 --- a/lisp/mml2015.el +++ b/lisp/mml2015.el @@ -77,27 +77,49 @@ (defvar mml2015-verify-function 'mailcrypt-verify) (defun mml2015-mailcrypt-decrypt (handle ctl) - (let (child handles result) - (unless (setq child (mm-find-part-by-type - (cdr handle) - "application/octet-stream" nil t)) - (error "Corrupted pgp-encrypted part.")) - (with-temp-buffer - (mm-insert-part child) - (setq result (funcall mml2015-decrypt-function)) - (unless (car result) - (error "Decrypting error.")) - (setq handles (mm-dissect-buffer t))) - (mm-destroy-parts handle) - (if (listp (car handles)) - handles - (list handles)))) + (catch 'error + (let (child handles result) + (unless (setq child (mm-find-part-by-type + (cdr handle) + "application/octet-stream" nil t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (with-temp-buffer + (mm-insert-part child) + (setq result + (condition-case err + (funcall mml2015-decrypt-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + nil))) + (unless (car result) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (throw 'error handle)) + (setq handles (mm-dissect-buffer t))) + (mm-destroy-parts handle) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (if (listp (car handles)) + handles + (list handles))))) (defun mml2015-mailcrypt-clear-decrypt () (let (result) - (setq result (funcall mml2015-decrypt-function)) - (unless (car result) - (error "Decrypting error.")))) + (setq result + (condition-case err + (funcall mml2015-decrypt-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + nil))) + (if (car result) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed")))) (defun mml2015-fix-micalg (alg) (upcase @@ -106,31 +128,53 @@ alg))) (defun mml2015-mailcrypt-verify (handle ctl) - (let (part) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mail-content-type-get ctl 'protocol) - "application/pgp-signature") - t)) - (error "Corrupted pgp-signature part.")) - (with-temp-buffer - (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") - (insert (format "Hash: %s\n\n" - (or (mml2015-fix-micalg - (mail-content-type-get ctl 'micalg)) - "SHA1"))) - (insert part "\n") - (goto-char (point-max)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (error "Corrupted pgp-signature part.")) - (mm-insert-part part) - (unless (funcall mml2015-verify-function) - (error "Verify error."))) - handle)) + (catch 'error + (let (part) + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mail-content-type-get ctl 'protocol) + "application/pgp-signature") + t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (with-temp-buffer + (insert "-----BEGIN PGP SIGNED MESSAGE-----\n") + (insert (format "Hash: %s\n\n" + (or (mml2015-fix-micalg + (mail-content-type-get ctl 'micalg)) + "SHA1"))) + (insert part "\n") + (goto-char (point-max)) + (unless (setq part (mm-find-part-by-type + (cdr handle) "application/pgp-signature" nil t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (mm-insert-part part) + (unless (condition-case err + (funcall mml2015-verify-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + nil)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (throw 'error handle))) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + handle))) (defun mml2015-mailcrypt-clear-verify () - (unless (funcall mml2015-verify-function) - (error "Verify error."))) + (if (condition-case err + (funcall mml2015-verify-function) + (error + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details (cadr err)) + nil)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed"))) (defun mml2015-mailcrypt-sign (cont) (mc-sign-generic (message-options-get 'message-sender) @@ -227,7 +271,9 @@ ;; Some wrong with the return value, check plain text buffer. (if (> (point-max) (point-min)) '(t) - (pop-to-buffer mml2015-result-buffer) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (buffer-string mml2015-result-buffer)) nil)))) (defun mml2015-gpg-decrypt (handle ctl) @@ -237,29 +283,41 @@ (defun mml2015-gpg-clear-decrypt () (let (result) (setq result (mml2015-gpg-decrypt-1)) - (unless (car result) - (error "Decrypting error.")))) + (if (car result) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "OK") + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed")))) (defun mml2015-gpg-verify (handle ctl) - (let (part message signature) - (unless (setq part (mm-find-raw-part-by-type - ctl (or (mail-content-type-get ctl 'protocol) - "application/pgp-signature") - t)) - (error "Corrupted pgp-signature part.")) - (with-temp-buffer - (setq message (current-buffer)) - (insert part) + (catch 'error + (let (part message signature) + (unless (setq part (mm-find-raw-part-by-type + ctl (or (mail-content-type-get ctl 'protocol) + "application/pgp-signature") + t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) (with-temp-buffer - (setq signature (current-buffer)) - (unless (setq part (mm-find-part-by-type - (cdr handle) "application/pgp-signature" nil t)) - (error "Corrupted pgp-signature part.")) - (mm-insert-part part) - (unless (gpg-verify message signature mml2015-result-buffer) - (pop-to-buffer mml2015-result-buffer) - (error "Verify error."))))) - handle) + (setq message (current-buffer)) + (insert part) + (with-temp-buffer + (setq signature (current-buffer)) + (unless (setq part (mm-find-part-by-type + (cdr handle) "application/pgp-signature" nil t)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Corrupted") + (throw 'error handle)) + (mm-insert-part part) + (unless (gpg-verify message signature mml2015-result-buffer) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-details + (buffer-string mml2015-result-buffer)) + (mm-set-handle-multipart-parameter + mm-security-handle 'gnus-info "Failed") + (throw 'error handle)))) + handle))) (defun mml2015-gpg-sign (cont) (let ((boundary diff --git a/texi/ChangeLog b/texi/ChangeLog index a2205a8..bdfdd34 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,7 @@ +2000-11-07 Martin Buchholz + + * gnus.texi: Doc fix. + 2000-11-01 Kai Gro,A_(Bjohann * gnus.texi (Fancy Mail Splitting): Explain diff --git a/texi/gnus.texi b/texi/gnus.texi index 37c1fcd..32e438a 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -14451,7 +14451,7 @@ predicates an additional score rule is superfluous. Predicates of @code{high} or @code{low} download articles in respect of their scores in relationship to @code{gnus-agent-high-score} and -@code{gnus-agent-low-score} as descibed below. +@code{gnus-agent-low-score} as described below. To gain even finer control of what is to be regarded eligible for download a predicate can consist of a number of predicates with logical -- 1.7.10.4