;; gnus-xmas.el overrides this for XEmacs.
((and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm))
- 'gnus-article-display-xface)
+ (if (module-installed-p 'x-face-e21)
+ 'x-face-decode-message-header
+ 'gnus-article-display-xface))
((and (not (featurep 'xemacs))
window-system
(module-installed-p 'x-face-mule))
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type '(choice string
+ (function-item
+ :tag "x-face-decode-message-header (x-face-e21)"
+ x-face-decode-message-header)
(function-item gnus-article-display-xface)
(function-item x-face-mule-gnus-article-display-x-face)
function)
: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)))
(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)
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
- (modify-syntax-entry ?- "w" table)
+ ;; This causes the citation match run O(2^n).
+ ;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?< "(" table)
table)
(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)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (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)
(call-interactively ',afunc)
(apply ',afunc args))))))))
'(article-hide-headers
+ article-verify-x-pgp-sig
article-hide-boring-headers
article-toggle-headers
article-treat-overstrike
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
+ "\C-hk" gnus-article-describe-key
+ "\C-hc" gnus-article-describe-key-briefly
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
(decf c))
keys))))
+(eval-when-compile
+ (defvar gnus-article-commands-menu))
+
(defun gnus-article-make-menu-bar ()
(gnus-turn-off-edit-menu 'article)
(unless (boundp 'gnus-article-article-menu)
(define-key gnus-article-mode-map [menu-bar post]
(cons "Post" gnus-summary-post-menu)))
- (gnus-run-hooks 'gnus-article-menu-hook)))
+ (gnus-run-hooks 'gnus-article-menu-hook))
+ ;; Add the menu.
+ (when (boundp 'gnus-article-commands-menu)
+ (easy-menu-add gnus-article-commands-menu gnus-article-mode-map))
+ (when (boundp 'gnus-summary-post-menu)
+ (easy-menu-add gnus-summary-post-menu gnus-article-mode-map)))
(defun gnus-article-mode ()
"Major mode for displaying an article.
(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
(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."
(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)))
- ;; Other multiparts are handled like multipart/mixed.
+ ;;(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-mime-display-mixed (cdr handle)))
+ (gnus-mime-display-security handle))
((equal (car handle) "multipart/encrypted")
(or (memq 'encrypted gnus-article-wash-types)
(push 'encrypted gnus-article-wash-types))
- (gnus-mime-display-mixed (cdr handle)))
+ (gnus-mime-display-security handle))
+ ;; Other multiparts are handled like multipart/mixed.
(t
(gnus-mime-display-mixed (cdr handle)))))
(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
(switch-to-buffer summary 'norecord))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
- (if (setq func (let (gnus-pick-mode)
- (lookup-key (current-local-map) keys)))
+ (if (and (setq func (let (gnus-pick-mode)
+ (lookup-key (current-local-map) keys)))
+ (functionp func))
(progn
(call-interactively func)
- (setq new-sum-point (point)))
- (ding))
- (when (eq in-buffer (current-buffer))
- (setq selected (gnus-summary-select-article))
- (set-buffer obuf)
- (unless not-restore-window
- (set-window-configuration owin))
- (when (eq selected 'old)
- (article-goto-body)
- (set-window-start (get-buffer-window (current-buffer))
- 1)
- (set-window-point (get-buffer-window (current-buffer))
- (point)))
- (let ((win (get-buffer-window gnus-article-current-summary)))
- (when win
- (set-window-point win new-sum-point))))))))
+ (setq new-sum-point (point))
+ (when (eq in-buffer (current-buffer))
+ (setq selected (gnus-summary-select-article))
+ (set-buffer obuf)
+ (unless not-restore-window
+ (set-window-configuration owin))
+ (when (eq selected 'old)
+ (article-goto-body)
+ (set-window-start (get-buffer-window (current-buffer))
+ 1)
+ (set-window-point (get-buffer-window (current-buffer))
+ (point)))
+ (let ((win (get-buffer-window gnus-article-current-summary)))
+ (when win
+ (set-window-point win new-sum-point)))) )
+ (switch-to-buffer gnus-article-buffer)
+ (ding))))))
+
+(defun gnus-article-describe-key (key)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: ")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (push (elt key 0) unread-command-events)
+ (setq key (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence "Describe key: "))
+ (read-key-sequence "Describe key: "))))
+ (describe-key key))
+ (describe-key key)))
+
+(defun gnus-article-describe-key-briefly (key &optional insert)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: \nP")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (push (elt key 0) unread-command-events)
+ (setq key (if (featurep 'xemacs)
+ (events-to-keys (read-key-sequence "Describe key: "))
+ (read-key-sequence "Describe key: "))))
+ (describe-key-briefly key insert))
+ (describe-key-briefly key insert)))
(defun gnus-article-hide (&optional arg force)
"Hide all the gruft in the current article.
(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-end-line-format "%{%([[End of %t]]%)%}\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-verify-or-decrypt (handle)
+ (mm-remove-parts (cdr handle))
+ (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
+ buffer-read-only)
+ (when region
+ (delete-region (car region) (cdr region))
+ (set-marker (car region) nil)
+ (set-marker (cdr region) nil)))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (let ((point (point))
+ buffer-read-only)
+ (gnus-mime-display-security handle)
+ (goto-char point)))
+
+(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-mime-security-press-button (handle)
+ (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (gnus-mime-security-show-details handle)
+ (gnus-mime-security-verify-or-decrypt handle)))
+
+(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")
+ " Part"))
+ (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-press-button
+ 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))))))
+
+(defun gnus-mime-display-security (handle)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle)
+ (gnus-mime-display-mixed (cdr handle))
+ (unless (bolp)
+ (insert "\n"))
+ (let ((gnus-mime-security-button-line-format
+ gnus-mime-security-button-end-line-format))
+ (gnus-insert-mime-security-button handle))
+ (mm-set-handle-multipart-parameter handle 'gnus-region
+ (cons (set-marker (make-marker)
+ (point-min))
+ (set-marker (make-marker)
+ (point-max))))))
+
;;; @ for mime-view
;;;
projects / elisp / gnus.git- / blobdiff