X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=89fc99f763cc9426da26559fe33a53b5837b8865;hb=f184970372ca060258c66979adbc7f1db73a9376;hp=cc31556d1d9e75d7e66e0bcba6cb384f71b71cd0;hpb=7f24f2b50cfa20ea1b4a69594432b1a851819020;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index cc31556..89fc99f 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -146,7 +146,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -689,10 +689,12 @@ used." (defcustom gnus-mime-action-alist '(("save to file" . gnus-mime-save-part) + ("save and strip" . gnus-mime-save-part-and-strip) ("display as text" . gnus-mime-inline-part) ("view the part" . gnus-mime-view-part) ("pipe to command" . gnus-mime-pipe-part) ("toggle display" . gnus-article-press-button) + ("toggle display" . gnus-article-view-part-as-charset) ("view as type" . gnus-mime-view-part-as-type) ("internalize type" . gnus-mime-internalize-part) ("externalize type" . gnus-mime-externalize-part)) @@ -1011,6 +1013,25 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-x-pgp-sig nil + "Verify X-PGP-Sig. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :group 'mime-security + :type gnus-article-treat-custom) + +(defvar gnus-article-encrypt-protocol-alist + '(("PGP" . mml2015-self-encrypt))) + +;; Set to nil if more than one protocol added to +;; gnus-article-encrypt-protocol-alist. +(defcustom gnus-article-encrypt-protocol "PGP" + "The protocol used for encrypt articles. +It is a string, such as \"PGP\". If nil, ask user." + :type 'string + :group 'mime-security) + ;;; Internal variables (defvar article-goto-body-goes-to-point-min-p nil) @@ -1021,6 +1042,7 @@ See the manual for details." (defvar gnus-treatment-function-alist '((gnus-treat-decode-article-as-default-mime-charset gnus-article-decode-article-as-default-mime-charset) + (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) (gnus-treat-strip-banner gnus-article-strip-banner) (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) (gnus-treat-buttonize gnus-article-add-buttons) @@ -2734,6 +2756,78 @@ If variable `gnus-use-long-file-name' is non-nil, it is (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) gnus-article-save-directory))) +(autoload 'mm-uu-pgp-signed-test "mm-uu") + +(defun article-verify-x-pgp-sig () + "Verify X-PGP-Sig." + (interactive) + (let ((sig (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "X-PGP-Sig"))) + items info headers) + (when (and sig (mm-uu-pgp-signed-test)) + (with-temp-buffer + (insert-buffer gnus-original-article-buffer) + (setq items (split-string sig)) + (message-narrow-to-head) + (let ((inhibit-point-motion-hooks t) + (case-fold-search t)) + ;; Don't verify multiple headers. + (setq headers (mapconcat (lambda (header) + (concat header ": " + (mail-fetch-field header) "\n")) + (split-string (nth 1 items) ",") ""))) + (delete-region (point-min) (point-max)) + (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") + (insert "X-Signed-Headers: " (nth 1 items) "\n") + (insert headers) + (widen) + (forward-line) + (while (not (eobp)) + (if (looking-at "^-") + (insert "- ")) + (forward-line)) + (insert "\n-----BEGIN PGP SIGNATURE-----\n") + (insert "Version: " (car items) "\n\n") + (insert (mapconcat 'identity (cddr items) "\n")) + (insert "\n-----END PGP SIGNATURE-----\n") + (let ((mm-security-handle (list (format "multipart/signed")))) + (mml2015-clean-buffer) + (let ((coding-system-for-write (or gnus-newsgroup-charset + 'iso-8859-1))) + (funcall (mml2015-clear-verify-function))) + (setq info + (or (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-details) + (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-info))))) + (when info + (let (buffer-read-only bface eface) + (save-restriction + (message-narrow-to-head) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (message-remove-header "X-Gnus-PGP-Verify") + (if (re-search-forward "^X-PGP-Sig:" nil t) + (forward-line) + (goto-char (point-max))) + (narrow-to-region (point) (point)) + (insert "X-Gnus-PGP-Verify: " info "\n") + (goto-char (point-min)) + (forward-line) + (while (not (eobp)) + (if (not (looking-at "^[ \t]")) + (insert " ")) + (forward-line)) + ;; Do highlighting. + (goto-char (point-min)) + (when (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (put-text-property (match-end 0) (point-max) + 'face eface)))))))) + (eval-and-compile (mapcar (lambda (func) @@ -2754,6 +2848,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (call-interactively ',afunc) (apply ',afunc args)))))))) '(article-hide-headers + article-verify-x-pgp-sig article-hide-boring-headers article-toggle-headers article-treat-overstrike @@ -2910,6 +3005,8 @@ commands: (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) (make-local-variable 'gnus-article-wash-types) + (make-local-variable 'gnus-article-charset) + (make-local-variable 'gnus-article-ignored-charsets) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -3287,7 +3384,9 @@ value of the variable `gnus-show-mime' is non-nil." '((gnus-article-press-button "\r" "Toggle Display") (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-view-part-as-type "t" "View As Type...") + (gnus-mime-view-part-as-charset "C" "View As charset...") (gnus-mime-save-part "o" "Save...") + (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") (gnus-mime-internalize-part "E" "View Internally") @@ -3314,9 +3413,9 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-mime-button-menu (event) "Construct a context-sensitive menu of MIME commands." (interactive "e") - (save-excursion + (save-window-excursion (let ((pos (event-start event))) - (set-buffer (window-buffer (posn-window pos))) + (select-window (posn-window pos)) (goto-char (posn-point pos)) (gnus-article-check-buffer) (let ((response (x-popup-menu @@ -3335,11 +3434,73 @@ 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." + (interactive) + (gnus-article-check-buffer) + (let* ((data (get-text-property (point) 'gnus-data)) + (file (mm-save-part data)) + param) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + (set-buffer gnus-summary-buffer) + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer gnus-original-article-buffer) + (mime-to-mml gnus-article-mime-handles) + (setq gnus-article-mime-handles nil) + (make-local-hook 'kill-buffer-hook) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight)))))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -3421,7 +3582,7 @@ value of the variable `gnus-show-mime' is non-nil." contents charset (b (point)) buffer-read-only) - (if (mm-handle-undisplayer handle) + (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) (setq contents (mm-get-part handle)) (cond @@ -3430,6 +3591,8 @@ value of the variable `gnus-show-mime' is non-nil." (mm-handle-type handle) 'charset) gnus-newsgroup-charset))) ((numberp arg) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) (setq charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) @@ -3444,6 +3607,23 @@ value of the variable `gnus-show-mime' is non-nil." contents)) (goto-char b)))) +(defun gnus-mime-view-part-as-charset (&optional handle arg) + "Insert the MIME part under point into the current buffer." + (interactive (list nil current-prefix-arg)) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents charset + (b (point)) + buffer-read-only) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (let ((gnus-newsgroup-charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (read-coding-system "Charset: "))) + (gnus-newsgroup-ignored-charsets 'gnus-all)) + (gnus-article-press-button)))) + (defun gnus-mime-externalize-part (&optional handle) "View the MIME part under point with an external viewer." (interactive) @@ -3514,6 +3694,11 @@ In no internal viewer is available, use an external viewer." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-copy-part)) +(defun gnus-article-view-part-as-charset (n) + "Copy MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) + (defun gnus-article-externalize-part (n) "View MIME part N externally, which is the numerical prefix." (interactive "p") @@ -3619,6 +3804,8 @@ In no internal viewer is available, use an external viewer." 'name) (mail-content-type-get (mm-handle-disposition handle) 'filename) + (mail-content-type-get (mm-handle-type handle) + 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description @@ -3750,7 +3937,21 @@ In no internal viewer is available, use an external viewer." (not gnus-mime-display-multipart-as-mixed)) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. - (gnus-mime-display-part (cadr handle))) + ;;(gnus-mime-display-part (cadr handle)) + ;;;!!! Most multipart/related is an HTML message plus images. + ;;;!!! Unfortunately we are unable to let W3 display those + ;;;!!! included images, so we just display it as a mixed multipart. + (gnus-mime-display-mixed (cdr handle))) + ((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))) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -3794,14 +3995,15 @@ In no internal viewer is available, use an external viewer." ;(gnus-article-insert-newline) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) - (gnus-article-insert-newline) - ;(gnus-article-insert-newline) + (gnus-article-insert-newline) + ;(gnus-article-insert-newline) + ;; Remember modify the number of forward lines. (setq move t)) (setq beg (point)) (cond (display (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets @@ -3813,7 +4015,7 @@ In no internal viewer is available, use an external viewer." (goto-char (point-max))) ((and text not-attachment) (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (gnus-article-insert-newline) (mm-insert-inline handle (mm-get-part handle)) @@ -3862,6 +4064,7 @@ In no internal viewer is available, use an external viewer." (unless (setq not-pref (cadr (member preferred ihandles))) (setq not-pref (car ihandles))) (when (or ibegend + (not preferred) (not (gnus-unbuttonized-mime-type-p "multipart/alternative"))) (gnus-add-text-properties @@ -3942,13 +4145,15 @@ In no internal viewer is available, use an external viewer." (boring (memq 'boring-headers gnus-article-wash-types)) (pgp (memq 'pgp gnus-article-wash-types)) (pem (memq 'pem gnus-article-wash-types)) + (signed (memq 'signed gnus-article-wash-types)) + (encrypted (memq 'encrypted gnus-article-wash-types)) (signature (memq 'signature gnus-article-wash-types)) (overstrike (memq 'overstrike gnus-article-wash-types)) (emphasis (memq 'emphasis gnus-article-wash-types))) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) (if (or headers boring) ?h ? ) - (if (or pgp pem) ?p ? ) + (if (or pgp pem signed encrypted) ?p ? ) (if signature ?s ? ) (if overstrike ?o ? ) (if gnus-show-mime ?m ? ) @@ -4480,27 +4685,6 @@ groups." (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (interactive "P") - (save-excursion - (save-restriction - (widen) - (when (article-goto-body) - (let ((lines (count-lines (point) (point-max))) - (length (- (point-max) (point))) - (case-fold-search t) - (body (copy-marker (point)))) - (goto-char (point-min)) - (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward - "^x-content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) @@ -5365,6 +5549,151 @@ For example: (t (error "%S is not a valid value" val)))) +(defun gnus-article-encrypt-body (protocol &optional n) + "Encrypt the article body." + (interactive + (list + (or gnus-article-encrypt-protocol + (completing-read "Encrypt protocol: " + gnus-article-encrypt-protocol-alist + nil t)) + current-prefix-arg)) + (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) + (unless func + (error (format "Can't find the encrypt protocol %s" protocol))) + (if (equal gnus-newsgroup-name "nndraft:drafts") + (error "Can't encrypt the article in group nndraft:drafts.")) + (if (equal gnus-newsgroup-name "nndraft:queue") + (error "Don't encrypt the article in group nndraft:queue.")) + (gnus-summary-iterate n + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) + (summary-buffer gnus-summary-buffer) + references point) + (gnus-set-global-variables) + (when (gnus-group-read-only-p) + (error "The current newsgroup does not support article encrypt")) + (gnus-summary-show-article t) + (setq references + (or (mail-header-references gnus-current-headers) "")) + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (headers + (mapcar (lambda (field) + (and (save-restriction + (message-narrow-to-head) + (goto-char (point-min)) + (search-forward field nil t)) + (prog2 + (message-narrow-to-field) + (buffer-substring (point-min) (point-max)) + (delete-region (point-min) (point-max)) + (widen)))) + '("Content-Type:" "Content-Transfer-Encoding:" + "Content-Disposition:")))) + (message-narrow-to-head) + (message-remove-header "MIME-Version") + (goto-char (point-max)) + (setq point (point)) + (insert (apply 'concat headers)) + (widen) + (narrow-to-region point (point-max)) + (let ((message-options message-options)) + (message-options-set 'message-sender user-mail-address) + (message-options-set 'message-recipients user-mail-address) + (message-options-set 'message-sign-encrypt 'not) + (funcall func)) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n") + (widen) + (gnus-summary-edit-article-done + references nil summary-buffer t)) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (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 ;;;