X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=7ccf5684431d308e9b5c678f0fd39aa199365be5;hb=5b431b1f3b1f5e57e5b56b18f744369a529e78d5;hp=01a8eeb4e5d03ff8f12101481566ecca34483ac8;hpb=7490ca5562b45f37db414347c77b03bb1200e2f9;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 01a8eeb4e..7ccf56844 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,5 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -46,10 +46,11 @@ (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") (autoload 'gnus-button-reply "gnus-msg" nil t) +(autoload 'ansi-color-apply-on-region "ansi-color") (defgroup gnus-article nil "Article display." - :link '(custom-manual "(gnus)The Article Buffer") + :link '(custom-manual "(gnus)Article Buffer") :group 'gnus) (defgroup gnus-article-treat nil @@ -149,7 +150,7 @@ "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway" "X-Local-Origin" "X-Local-Destination" "X-UserInfo1" "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications" - "X-Abuse-and-DMCA-Info" "X-Postfilter")) + "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer")) "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." @@ -243,8 +244,8 @@ regexp. If it matches, the text in question is not a signature." :type 'sexp :group 'gnus-article-hiding) -;; Fixme: This isn't the right thing for mixed graphical and and -;; non-graphical frames in a session. +;; Fixme: This isn't the right thing for mixed graphical and non-graphical +;; frames in a session. (defcustom gnus-article-x-face-command (if (featurep 'xemacs) (if (or (gnus-image-type-available-p 'xface) @@ -336,8 +337,6 @@ advertisements. For example: (format format (car spec) (cadr spec)) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types) - ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)" - 2 3 gnus-emphasis-strikethru) ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 2 3 gnus-emphasis-underline))) "*Alist that says how to fontify certain phrases. @@ -396,7 +395,9 @@ and the latter avoids underlining any whitespace at all." Example: (_/*word*/_)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-strikethru '((t (:strikethru t))) +(defface gnus-emphasis-strikethru (if (featurep 'xemacs) + '((t (:strikethru t))) + '((t (:strike-through t)))) "Face used for displaying strike-through text (-word-)." :group 'gnus-article-emphasis) @@ -560,8 +561,7 @@ The following additional specs are available: :type 'hook :group 'gnus-article-various) -(defvar gnus-article-hide-pgp-hook nil) -(make-obsolete-variable 'gnus-article-hide-pgp-hook +(make-obsolete-variable 'gnus-article-hide-pgp-hook "This variable is obsolete in Gnus 5.10.") (defcustom gnus-article-button-face 'bold @@ -629,7 +629,9 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." (:foreground "MidnightBlue" :italic t)) (t (:italic t))) - "Face used for displaying newsgroups headers." + "Face used for displaying newsgroups headers. +In the default setup this face is only used for crossposted +articles." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -663,17 +665,17 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." ("Subject" nil gnus-header-subject-face) ("Newsgroups:.*," nil gnus-header-newsgroups-face) ("" gnus-header-name-face gnus-header-content-face)) - "*Controls highlighting of article header. + "*Controls highlighting of article headers. An alist of the form (HEADER NAME CONTENT). -HEADER is a regular expression which should match the name of an -header header and NAME and CONTENT are either face names or nil. +HEADER is a regular expression which should match the name of a +header and NAME and CONTENT are either face names or nil. The name of each header field will be displayed using the face -specified by the first element in the list where HEADER match the -header name and NAME is non-nil. Similarly, the content will be -displayed by the first non-nil matching CONTENT face." +specified by the first element in the list where HEADER matches +the header name and NAME is non-nil. Similarly, the content will +be displayed by the first non-nil matching CONTENT face." :group 'gnus-article-headers :group 'gnus-article-highlight :type '(repeat (list (regexp :tag "Header") @@ -751,6 +753,7 @@ When nil (the default value), then some MIME parts do not get buttons, as described by the variables `gnus-buttonized-mime-types' and `gnus-unbuttonized-mime-types'." :version "21.3" + :group 'gnus-article-mime :type 'boolean) (defcustom gnus-body-boundary-delimiter "_" @@ -790,7 +793,7 @@ on parts -- for instance, adding Vcard info to a database." "An alist of MIME types to functions to display them." :version "21.1" :group 'gnus-article-mime - :type 'alist) + :type '(repeat (cons :format "%v" (string :tag "MIME type") function))) (defcustom gnus-article-date-lapsed-new-header nil "Whether the X-Sent and Date headers can coexist. @@ -890,8 +893,7 @@ See Info node `(gnus)Customizing Articles' for details." (defcustom gnus-treat-emphasize (and (or window-system - (featurep 'xemacs) - (>= (string-to-number emacs-version) 21)) + (featurep 'xemacs)) 50000) "Emphasize text. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -982,7 +984,7 @@ See Info node `(gnus)Customizing Articles' for details." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(make-obsolete-variable 'gnus-treat-strip-pgp +(make-obsolete-variable 'gnus-treat-strip-pgp "This option is obsolete in Gnus 5.10.") (defcustom gnus-treat-strip-pem nil @@ -1144,7 +1146,18 @@ See Info node `(gnus)Customizing Articles' for details." :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-display-xface +(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t) + "Treat ANSI SGR control sequences. +Valid values are nil, t, `head', `last', an integer or a predicate. +See Info node `(gnus)Customizing Articles' for details." + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-custom) + +(make-obsolete-variable 'gnus-treat-display-xface + 'gnus-treat-display-x-face) + +(defcustom gnus-treat-display-x-face (and (not noninteractive) (or (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm) @@ -1161,8 +1174,25 @@ See Info node `(gnus)Customizing Articles' and Info node :version "21.1" :link '(custom-manual "(gnus)Customizing Articles") :link '(custom-manual "(gnus)X-Face") - :type gnus-article-treat-head-custom) -(put 'gnus-treat-display-xface 'highlight t) + :type gnus-article-treat-head-custom + :set (lambda (symbol value) + (set-default + symbol + (cond ((or (boundp symbol) (get symbol 'saved-value)) + value) + ((boundp 'gnus-treat-display-xface) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (default-value 'gnus-treat-display-xface)) + ((get 'gnus-treat-display-xface 'saved-value) + (message "\ +** gnus-treat-display-xface is an obsolete variable;\ + use gnus-treat-display-x-face instead") + (eval (car (get 'gnus-treat-display-xface 'saved-value)))) + (t + value))))) +(put 'gnus-treat-display-x-face 'highlight t) (defcustom gnus-treat-display-face (and (not noninteractive) @@ -1180,7 +1210,7 @@ See Info node `(gnus)Customizing Articles' and Info node :link '(custom-manual "(gnus)Customizing Articles") :link '(custom-manual "(gnus)X-Face") :type gnus-article-treat-head-custom) -(put 'gnus-treat-display-xface 'highlight t) +(put 'gnus-treat-display-face 'highlight t) (defcustom gnus-treat-display-smileys (if (or (and (featurep 'xemacs) @@ -1250,12 +1280,12 @@ See Info node `(gnus)Customizing Articles' and Info node gnus-treat-from-picon) 'head nil) "Draw a boundary at the end of the headers. -Valid values are nil, t, `head', `last', an integer or a predicate. +Valid values are nil and `head'. See Info node `(gnus)Customizing Articles' for details." :version "21.1" :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) + :type gnus-article-treat-head-custom) (defcustom gnus-treat-capitalize-sentences nil "Capitalize sentence-starting words. @@ -1325,8 +1355,8 @@ It is a string, such as \"PGP\". If nil, ask user." "Function used for converting HTML into text.") (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) - (fboundp 'coding-system-p) - (coding-system-p 'utf-8)) + (mm-coding-system-p 'utf-8) + (executable-find idna-program)) "Whether IDNA decoding of headers is used when viewing messages. This requires GNU Libidn, and by default only enabled if it is found." :group 'gnus-article-headers @@ -1343,6 +1373,13 @@ This requires GNU Libidn, and by default only enabled if it is found." '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) +(defvar gnus-button-regexp nil) +(defvar gnus-button-marker-list nil) +;; Regexp matching any of the regexps from `gnus-button-alist'. + +(defvar gnus-button-last nil) +;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. + (defvar article-goto-body-goes-to-point-min-p nil) (defvar gnus-article-wash-types nil) (defvar gnus-article-emphasis-alist nil) @@ -1366,7 +1403,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-date-original gnus-article-date-original) (gnus-treat-date-user-defined gnus-article-date-user) (gnus-treat-date-iso8601 gnus-article-date-iso8601) - (gnus-treat-display-xface gnus-article-display-x-face) + (gnus-treat-display-x-face gnus-article-display-x-face) (gnus-treat-display-face gnus-article-display-face) (gnus-treat-hide-headers gnus-article-maybe-hide-headers) (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) @@ -1386,6 +1423,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-strip-multiple-blank-lines gnus-article-strip-multiple-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) + (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences) (gnus-treat-unfold-headers gnus-article-treat-unfold-headers) (gnus-treat-fold-headers gnus-article-treat-fold-headers) (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups) @@ -1428,6 +1466,8 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-inhibit-hiding nil) +(defvar gnus-article-edit-mode nil) + ;;; Macros for dealing with the article buffer. (defmacro gnus-with-article-headers (&rest forms) @@ -1606,7 +1646,7 @@ always hide." (while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t) (forward-line -1) (gnus-article-hide-text-type - (gnus-point-at-bol) + (point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1667,15 +1707,25 @@ always hide." (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) - (let ((from (message-fetch-field "from")) - (reply-to (message-fetch-field "reply-to"))) - (when (and + (if (gnus-group-find-parameter + gnus-newsgroup-name 'broken-reply-to) + (gnus-article-hide-header "reply-to") + (let ((from (message-fetch-field "from")) + (reply-to (message-fetch-field "reply-to"))) + (when + (and from reply-to (ignore-errors - (gnus-string-equal - (nth 1 (mail-extract-address-components from)) - (nth 1 (mail-extract-address-components reply-to))))) - (gnus-article-hide-header "reply-to")))) + (equal + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components from t)) + 'string<) + (sort (mapcar + (lambda (x) (downcase (cadr x))) + (mail-extract-address-components reply-to t)) + 'string<)))) + (gnus-article-hide-header "reply-to"))))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) (when (and date @@ -1722,7 +1772,7 @@ always hide." (goto-char (point-min)) (when (re-search-forward (concat "^" header ":") nil t) (gnus-article-hide-text-type - (gnus-point-at-bol) + (point-at-bol) (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) @@ -1743,7 +1793,7 @@ always hide." (article-narrow-to-head) (while (not (eobp)) (cond - ((< (setq column (- (gnus-point-at-eol) (point))) + ((< (setq column (- (point-at-eol) (point))) gnus-article-normalized-header-length) (end-of-line) (insert (make-string @@ -1754,7 +1804,7 @@ always hide." (progn (forward-char gnus-article-normalized-header-length) (point)) - (gnus-point-at-eol) + (point-at-eol) 'invisible t)) (t ;; Do nothing. @@ -1762,14 +1812,15 @@ always hide." (forward-line 1)))))) (defun article-treat-dumbquotes () - "Translate M****s*** sm*rtq**t*s into proper text. + "Translate M****s*** sm*rtq**t*s and other symbols into proper text. Note that this function guesses whether a character is a sm*rtq**t* or not, so it should only be used interactively. -Sm*rtq**t*s are M****s***'s unilateral extension to the character map -in an attempt to provide more quoting characters. If you see -something like \\222 or \\264 where you're expecting some kind of -apostrophe or quotation mark, then try this wash." +Sm*rtq**t*s are M****s***'s unilateral extension to the +iso-8859-1 character map in an attempt to provide more quoting +characters. If you see something like \\222 or \\264 where +you're expecting some kind of apostrophe or quotation mark, then +try this wash." (interactive) (article-translate-strings gnus-article-dumbquotes-map)) @@ -1828,6 +1879,14 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (put-text-property (point) (1+ (point)) 'face 'underline))))))))) +(defun article-treat-ansi-sequences () + "Translate ANSI SGR control sequences into overlays or extents." + (interactive) + (save-excursion + (when (article-goto-body) + (let ((buffer-read-only nil)) + (ansi-color-apply-on-region (point) (point-max)))))) + (defun gnus-article-treat-unfold-headers () "Unfold folded message headers. Only the headers that fit into the current window width will be @@ -1924,7 +1983,7 @@ unfolded." (end-of-line) (when (>= (current-column) (min fill-column width)) (narrow-to-region (min (1+ (point)) (point-max)) - (gnus-point-at-bol)) + (point-at-bol)) (let ((goback (point-marker))) (fill-paragraph nil) (goto-char (marker-position goback))) @@ -1966,28 +2025,53 @@ unfolded." (while (and (not (bobp)) (looking-at "^[ \t]*$") (not (gnus-annotation-in-region-p - (point) (gnus-point-at-eol)))) + (point) (point-at-eol)))) (forward-line -1)) (forward-line 1) (point)))))) +(eval-when-compile + (defvar gnus-face-properties-alist)) + (defun article-display-face () "Display any Face headers in the header." (interactive) - (gnus-with-article-headers - (let ((face (message-fetch-field "face"))) - (when face - (let ((png (gnus-convert-face-to-png face)) - image) - (when png - (setq image (gnus-create-image png 'png t)) - (gnus-article-goto-header "from") - (when (bobp) - (insert "From: [no `from' set]\n") - (forward-char -17)) - (gnus-add-wash-type 'face) - (gnus-add-image 'face image) - (gnus-put-image image))))))) + (let ((wash-face-p buffer-read-only)) + (gnus-with-article-headers + ;; When displaying parts, this function can be called several times on + ;; the same article, without any intended toggle semantic (as typing `W + ;; D d' would have). So face deletion must occur only when we come from + ;; an interactive command, that is when the *Article* buffer is + ;; read-only. + (if (and wash-face-p (memq 'face gnus-article-wash-types)) + (gnus-delete-images 'face) + (let (face faces) + (save-excursion + (when (and wash-face-p + (progn + (goto-char (point-min)) + (not (re-search-forward "^Face:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + (set-buffer gnus-original-article-buffer)) + (save-restriction + (mail-narrow-to-head) + (while (gnus-article-goto-header "Face") + (setq faces (nconc faces (list (mail-header-field-value))))))) + (while (setq face (pop faces)) + (let ((png (gnus-convert-face-to-png face)) + image) + (when png + (setq image + (apply 'gnus-create-image png 'png t + (cdr (assq 'png gnus-face-properties-alist)))) + (gnus-article-goto-header "from") + (when (bobp) + (insert "From: [no `from' set]\n") + (forward-char -17)) + (gnus-add-wash-type 'face) + (gnus-add-image 'face image) + (gnus-put-image image nil 'face)))))) + ))) (defun article-display-x-face (&optional force) "Look for an X-Face header and display it if present." @@ -1997,7 +2081,8 @@ unfolded." ;; Delete the old process, if any. (when (process-status "article-x-face") (delete-process "article-x-face")) - (if (memq 'xface gnus-article-wash-types) + ;; See the comment in `article-display-face'. + (if (and wash-face-p (memq 'xface gnus-article-wash-types)) ;; We have already displayed X-Faces, so we remove them ;; instead. (gnus-delete-images 'xface) @@ -2032,35 +2117,35 @@ unfolded." (not (string-match gnus-article-x-face-too-ugly from))))) ;; We display the face. - (if (symbolp gnus-article-x-face-command) - ;; The command is a lisp function, so we call it. - (if (gnus-functionp gnus-article-x-face-command) - (funcall gnus-article-x-face-command face) - (error "%s is not a function" gnus-article-x-face-command)) - ;; The command is a string, so we interpret the command - ;; as a, well, command, and fork it off. - (let ((process-connection-type nil)) - (process-kill-without-query - (start-process - "article-x-face" nil shell-file-name shell-command-switch - gnus-article-x-face-command)) - (with-temp-buffer - (insert face) - (process-send-region "article-x-face" - (point-min) (point-max))) - (process-send-eof "article-x-face"))))))))) + (cond ((stringp gnus-article-x-face-command) + ;; The command is a string, so we interpret the command + ;; as a, well, command, and fork it off. + (let ((process-connection-type nil)) + (process-kill-without-query + (start-process + "article-x-face" nil shell-file-name + shell-command-switch gnus-article-x-face-command)) + (with-temp-buffer + (insert face) + (process-send-region "article-x-face" + (point-min) (point-max))) + (process-send-eof "article-x-face"))) + ((functionp gnus-article-x-face-command) + ;; The command is a lisp function, so we call it. + (funcall gnus-article-x-face-command face)) + (t + (error "%s is not a function" + gnus-article-x-face-command))))))))) (defun article-decode-mime-words () "Decode all MIME-encoded words in the article." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (gnus-with-article-buffer (let ((inhibit-point-motion-hooks t) - buffer-read-only (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (mail-decode-encoded-word-region (point-min) (point-max))))) (defun article-decode-charset (&optional prompt) @@ -2107,7 +2192,7 @@ If PROMPT (the prefix), prompt for a coding system to use." (mm-decode-body charset (and cte (intern (downcase (gnus-strip-whitespace cte)))) - (car ctl) prompt)))))) + (car ctl))))))) (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." @@ -2173,15 +2258,13 @@ If PROMPT (the prefix), prompt for a coding system to use." buffer-read-only) (article-narrow-to-head) (goto-char (point-min)) - (while (re-search-forward "\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) + (while (re-search-forward "@.*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t) (let (ace unicode) (when (save-match-data (and (setq ace (match-string 1)) (save-excursion (and (re-search-backward "^[^ \t]" nil t) (looking-at "From\\|To\\|Cc"))) - (save-excursion (backward-char) - (message-idna-inside-rhs-p)) (setq unicode (idna-to-unicode ace)))) (unless (string= ace unicode) (replace-match unicode nil nil nil 1))))))))) @@ -2270,8 +2353,8 @@ If READ-CHARSET, ask for a coding system." (while (re-search-forward "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t) (replace-match "\\1\\3" t))) - (when (and gnus-display-mime-function (interactive-p)) - (funcall gnus-display-mime-function)))) + (when (interactive-p) + (gnus-treat-article nil)))) (defun article-wash-html (&optional read-charset) @@ -2304,7 +2387,7 @@ If READ-CHARSET, ask for a coding system." (when entry (setq func (cdr entry))) (cond - ((gnus-functionp func) + ((functionp func) (funcall func)) (t (apply (car func) (cdr func)))))))))) @@ -2325,16 +2408,17 @@ If READ-CHARSET, ask for a coding system." (mm-setup-w3m) (save-restriction (narrow-to-region (point) (point-max)) - (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images - nil - "\\`cid:")) + (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) w3m-force-redisplay) (w3m-region (point-min) (point-max))) - (when mm-inline-text-html-with-w3m-keymap + (when (and mm-inline-text-html-with-w3m-keymap + (boundp 'w3m-minor-mode-map) + w3m-minor-mode-map) (add-text-properties (point-min) (point-max) - (nconc (mm-w3m-local-map-property) - '(mm-inline-text-html-with-w3m t)))))) + (list 'keymap w3m-minor-mode-map + ;; Put the mark meaning this part was rendered by emacs-w3m. + 'mm-inline-text-html-with-w3m t))))) (defun article-hide-list-identifiers () "Remove list identifies from the Subject header. @@ -2397,18 +2481,25 @@ always hide." (article-really-strip-banner (gnus-parameter-banner gnus-newsgroup-name))) (when gnus-article-address-banner-alist - (article-really-strip-banner - (let ((from (save-restriction - (widen) - (article-narrow-to-head) - (mail-fetch-field "from")))) - (when (and from - (setq from - (caar (mail-header-parse-addresses from)))) - (catch 'found - (dolist (pair gnus-article-address-banner-alist) - (when (string-match (car pair) from) - (throw 'found (cdr pair))))))))))))) + ;; It is necessary to encode from fields before checking, + ;; because `mail-header-parse-addresses' does not work + ;; (reliably) on decoded headers. And more, it is + ;; impossible to use `gnus-fetch-original-field' here, + ;; because `article-strip-banner' may be called in draft + ;; buffers to preview them. + (let ((from (save-restriction + (widen) + (article-narrow-to-head) + (mail-fetch-field "from")))) + (when (and from + (setq from + (caar (mail-header-parse-addresses + (mail-encode-encoded-word-string from))))) + (catch 'found + (dolist (pair gnus-article-address-banner-alist) + (when (string-match (car pair) from) + (throw 'found + (article-really-strip-banner (cdr pair))))))))))))) (defun article-really-strip-banner (banner) "Strip the banner specified by the argument." @@ -2436,11 +2527,9 @@ always hide." "Translate article using an online translation service." (interactive) (require 'babel) - (save-excursion - (set-buffer gnus-article-buffer) + (gnus-with-article-buffer (when (article-goto-body) - (let* ((buffer-read-only nil) - (start (point)) + (let* ((start (point)) (end (point-max)) (orig (buffer-substring start end)) (trans (babel-as-string orig))) @@ -2578,7 +2667,7 @@ Point is left at the beginning of the narrowed-to region." (< (- (point-max) (point)) limit)) (and (floatp limit) (< (count-lines (point) (point-max)) limit)) - (and (gnus-functionp limit) + (and (functionp limit) (funcall limit)) (and (stringp limit) (not (re-search-forward limit nil t)))) @@ -2704,11 +2793,11 @@ should replace the \"Date:\" one, or should be added below it." (save-restriction (article-narrow-to-head) (when (re-search-forward tdate-regexp nil t) - (setq bface (get-text-property (gnus-point-at-bol) 'face) - date (or (get-text-property (gnus-point-at-bol) + (setq bface (get-text-property (point-at-bol) 'face) + date (or (get-text-property (point-at-bol) 'original-date) date) - eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + eface (get-text-property (1- (point-at-eol)) 'face)) (forward-line 1)) (when (and date (not (string= date ""))) (goto-char (point-min)) @@ -2716,19 +2805,18 @@ should replace the \"Date:\" one, or should be added below it." ;; Delete any old Date headers. (while (re-search-forward date-regexp nil t) (if pos - (delete-region (progn (beginning-of-line) (point)) - (progn (gnus-article-forward-header) - (point))) - (delete-region (progn (beginning-of-line) (point)) + (delete-region (point-at-bol) (progn (gnus-article-forward-header) - (forward-char -1) (point))) + (delete-region (point-at-bol) + (progn (gnus-article-forward-header) + (forward-char -1) + (point))) (setq pos (point)))) (when (and (not pos) (re-search-forward tdate-regexp nil t)) (forward-line 1)) - (when pos - (goto-char pos)) + (gnus-goto-char pos) (insert (article-make-date-line date (or type 'ut))) (unless pos (insert "\n") @@ -2780,7 +2868,7 @@ should replace the \"Date:\" one, or should be added below it." gnus-article-time-format) (error nil)) gnus-article-time-format))) - (if (gnus-functionp format) + (if (functionp format) (funcall format time) (concat "Date: " (format-time-string format time))))) ;; ISO 8601. @@ -2890,9 +2978,12 @@ function and want to see what the date was before converting." (lambda (w) (set-buffer (window-buffer w)) (when (eq major-mode 'gnus-article-mode) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t)))) + (let ((mark (point-marker))) + (goto-char (point-min)) + (when (re-search-forward "^X-Sent:" nil t) + (article-date-lapsed t)) + (goto-char (marker-position mark)) + (move-marker mark nil)))) nil 'visible))))) (defun gnus-start-date-timer (&optional n) @@ -2904,7 +2995,7 @@ is to run." (setq n 1)) (gnus-stop-date-timer) (setq article-lapsed-timer - (nnheader-run-at-time 1 n 'article-update-date-lapsed))) + (run-at-time 1 n 'article-update-date-lapsed))) (defun gnus-stop-date-timer () "Stop the X-Sent timer." @@ -3350,8 +3441,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (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)) + (setq bface (get-text-property (point-at-bol) 'face) + eface (get-text-property (1- (point-at-eol)) 'face)) (message-remove-header "X-Gnus-PGP-Verify") (if (re-search-forward "^X-PGP-Sig:" nil t) (forward-line) @@ -3402,6 +3493,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-verify-cancel-lock article-hide-boring-headers article-treat-overstrike + article-treat-ansi-sequences article-fill-long-lines article-capitalize-sentences article-remove-cr @@ -3502,6 +3594,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] + ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t] ["Remove carriage return" gnus-article-remove-cr t] ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t] @@ -3543,7 +3636,7 @@ commands: (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) - (make-local-variable 'gnus-page-broken) + (set (make-local-variable 'gnus-page-broken) nil) (make-local-variable 'gnus-button-marker-list) (make-local-variable 'gnus-article-current-summary) (make-local-variable 'gnus-article-mime-handles) @@ -3727,10 +3820,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-prepare-display) ;; Do page break. (goto-char (point-min)) - (setq gnus-page-broken - (when gnus-break-pages - (gnus-narrow-to-page) - t))) + (when gnus-break-pages + (gnus-narrow-to-page))) (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) (gnus-set-mode-line 'article)) @@ -3811,9 +3902,6 @@ General format specifiers can also be used. See Info node (defvar gnus-mime-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-article-push-button) (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) (dolist (c gnus-mime-button-commands) @@ -3827,22 +3915,6 @@ General format specifiers can also be used. See Info node (vector (caddr c) (car c) :enable t)) gnus-mime-button-commands))) -(eval-when-compile - (define-compiler-macro popup-menu (&whole form - menu &optional position prefix) - (if (and (fboundp 'popup-menu) - (not (memq 'popup-menu (assoc "lmenu" load-history)))) - form - ;; Gnus is probably running under Emacs 20. - `(let* ((menu (cdr ,menu)) - (response (x-popup-menu - t (list (car menu) - (cons "" (mapcar (lambda (c) - (cons (caddr c) (car c))) - (cdr menu))))))) - (if response - (call-interactively (nth 3 (assq response menu)))))))) - (defun gnus-mime-button-menu (event prefix) "Construct a context-sensitive menu of MIME commands." (interactive "e\nP") @@ -3856,8 +3928,7 @@ General format specifiers can also be used. See Info node (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." (interactive) - (save-current-buffer - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets @@ -3871,109 +3942,11 @@ General format specifiers can also be used. See Info node (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 param - (handles gnus-article-mime-handles)) - (if (mm-multiple-handles gnus-article-mime-handles) - (error "This function is not implemented")) - (setq file (and data (mm-save-part data))) - (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 ',handles) - (setq gnus-article-mime-handles nil) - (let ((mbl1 mml-buffer-list)) - (setq mml-buffer-list mbl) - (set (make-local-variable 'mml-buffer-list) mbl1)) - ;; LOCAL argument of add-hook differs between GNU Emacs - ;; and XEmacs. make-local-hook makes sure they are local. - (make-local-hook 'kill-buffer-hook) - (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-delete-part () - "Delete the MIME part under point. -Replace it with some information about the removed part." - (interactive) - (gnus-article-check-buffer) - (let* ((data (get-text-property (point) 'gnus-data)) - (handles gnus-article-mime-handles) - (none "(none)") - (description - (or - (mail-decode-encoded-word-string (or (mm-handle-description data) - none)))) - (filename - (or (mail-content-type-get (mm-handle-disposition data) 'filename) - none)) - (type (mm-handle-media-type data))) - (if (mm-multiple-handles gnus-article-mime-handles) - (error "This function is not implemented")) - (with-current-buffer (mm-handle-buffer data) - (let ((bsize (format "%s" (buffer-size)))) - (erase-buffer) - (insert - (concat - "<#part type=text/plain nofile=yes disposition=attachment" - " description=\"Deleted attachment (" bsize " Byte)\">" - ",----\n" - "| The following attachment has been deleted:\n" - "|\n" - "| Type: " type "\n" - "| Filename: " filename "\n" - "| Size (encoded): " bsize " Byte\n" - "| Description: " description "\n" - "`----\n" - "<#/part>")) - (setcdr data - (cdr (mm-make-handle nil `("text/plain")))))) - (set-buffer gnus-summary-buffer) - ;; FIXME: maybe some of the following code (borrowed from - ;; `gnus-mime-save-part-and-strip') isn't necessary? +(eval-when-compile + (defsubst gnus-article-edit-part (handles) + "Edit an article in order to delete a mime part. +This function is exclusively used by `gnus-mime-save-part-and-strip' +and `gnus-mime-delete-part', and not provided at run-time normally." (gnus-article-edit-article `(lambda () (erase-buffer) @@ -3990,9 +3963,7 @@ Replace it with some information about the removed part." (let ((mbl1 mml-buffer-list)) (setq mml-buffer-list mbl) (set (make-local-variable 'mml-buffer-list) mbl1)) - ;; LOCAL argument of add-hook differs between GNU Emacs - ;; and XEmacs. make-local-hook makes sure they are local. - (make-local-hook 'kill-buffer-hook) + (gnus-make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) `(lambda (no-highlight) (let ((mail-parse-charset (or gnus-article-charset @@ -4010,11 +3981,89 @@ Replace it with some information about the removed part." (gnus-summary-edit-article-done ,(or (mail-header-references gnus-current-headers) "") ,(gnus-group-read-only-p) - ,gnus-summary-buffer no-highlight)))) - ;; Not in `gnus-mime-save-part-and-strip': - (gnus-article-edit-done) - (gnus-summary-expand-window) - (gnus-summary-show-article)) + ,gnus-summary-buffer no-highlight))) + (gnus-article-edit-done) + (gnus-summary-expand-window) + (gnus-summary-show-article))) + +(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) + (when (gnus-group-read-only-p) + (error "The current group does not support deleting of parts")) + (when (mm-complicated-handles gnus-article-mime-handles) + (error "\ +The current article has a complicated MIME structure, giving up...")) + (when (gnus-yes-or-no-p "\ +Deleting parts may malfunction or destroy the article; continue? ") + (let* ((data (get-text-property (point) 'gnus-data)) + file param + (handles gnus-article-mime-handles)) + (setq file (and data (mm-save-part data))) + (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-part handles))))) + +(defun gnus-mime-delete-part () + "Delete the MIME part under point. +Replace it with some information about the removed part." + (interactive) + (gnus-article-check-buffer) + (when (gnus-group-read-only-p) + (error "The current group does not support deleting of parts")) + (when (mm-complicated-handles gnus-article-mime-handles) + (error "\ +The current article has a complicated MIME structure, giving up...")) + (when (gnus-yes-or-no-p "\ +Deleting parts may malfunction or destroy the article; continue? ") + (let* ((data (get-text-property (point) 'gnus-data)) + (handles gnus-article-mime-handles) + (none "(none)") + (description + (or + (mail-decode-encoded-word-string (or (mm-handle-description data) + none)))) + (filename + (or (mail-content-type-get (mm-handle-disposition data) 'filename) + none)) + (type (mm-handle-media-type data))) + (unless data + (error "No MIME part under point")) + (with-current-buffer (mm-handle-buffer data) + (let ((bsize (format "%s" (buffer-size)))) + (erase-buffer) + (insert + (concat + ",----\n" + "| The following attachment has been deleted:\n" + "|\n" + "| Type: " type "\n" + "| Filename: " filename "\n" + "| Size (encoded): " bsize " Byte\n" + "| Description: " description "\n" + "`----\n")) + (setcdr data + (cdr (mm-make-handle + nil `("text/plain") nil nil + (list "attachment") + (format "Deleted attachment (%s bytes)" bsize)))))) + (set-buffer gnus-summary-buffer) + (gnus-article-edit-part handles)))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -4098,7 +4147,7 @@ The uncompress method used is derived from `buffer-file-name'." (message "%s %s..." message basename)) (unwind-protect (unless (memq (apply 'call-process-region - (point-min) (point-max) + (point-min) (point-max) prog t (list t err-file) nil args) @@ -4221,8 +4270,8 @@ specified charset." (mm-inlined-types nil) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (when handle (if (mm-handle-undisplayer handle) (mm-remove-part handle) @@ -4238,8 +4287,8 @@ If no internal viewer is available, use an external viewer." (mm-inline-large-images t) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets)) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets)) buffer-read-only) (when handle (if (mm-handle-undisplayer handle) @@ -4256,8 +4305,7 @@ If no internal viewer is available, use an external viewer." (funcall (cdr action-pair))))) (defun gnus-article-part-wrapper (n function) - (save-current-buffer - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) (gnus-article-goto-part n) @@ -4285,7 +4333,8 @@ If no internal viewer is available, use an external viewer." (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." + "View MIME part N using a specified charset. +N is the numerical prefix." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) @@ -4322,8 +4371,7 @@ If no internal viewer is available, use an external viewer." (defun gnus-article-view-part (&optional n) "View MIME part N, which is the numerical prefix." (interactive "P") - (save-current-buffer - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (or (numberp n) (setq n (gnus-article-mime-match-handle-first gnus-article-mime-match-handle-function))) (when (> n (length gnus-article-mime-handle-alist)) @@ -4351,8 +4399,7 @@ If no internal viewer is available, use an external viewer." (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (if (gnus-buffer-live-p gnus-summary-buffer) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets) nil))) (save-excursion @@ -4420,11 +4467,11 @@ If no internal viewer is available, use an external viewer." (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist - `(,@(gnus-local-map-property gnus-mime-button-map) - gnus-callback gnus-mm-display-part - gnus-part ,gnus-tmp-id - article-type annotation - gnus-data ,handle)) + `(keymap ,gnus-mime-button-map + gnus-callback gnus-mm-display-part + gnus-part ,gnus-tmp-id + article-type annotation + gnus-data ,handle)) (setq e (if (bolp) ;; Exclude a newline. (1- (point)) @@ -4510,9 +4557,28 @@ If no internal viewer is available, use an external viewer." (narrow-to-region (point-min) (point)) (gnus-treat-article 'head)))))))) -(defvar gnus-mime-display-multipart-as-mixed nil) -(defvar gnus-mime-display-multipart-alternative-as-mixed nil) -(defvar gnus-mime-display-multipart-related-as-mixed nil) +(defcustom gnus-mime-display-multipart-as-mixed nil + "Display \"multipart\" parts as \"multipart/mixed\". + +If t, it overrides nil values of +`gnus-mime-display-multipart-alternative-as-mixed' and +`gnus-mime-display-multipart-related-as-mixed'." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-alternative-as-mixed nil + "Display \"multipart/alternative\" parts as \"multipart/mixed\"." + :group 'gnus-article-mime + :type 'boolean) + +(defcustom gnus-mime-display-multipart-related-as-mixed nil + "Display \"multipart/related\" parts as \"multipart/mixed\". + +If displaying \"text/html\" is discouraged \(see +`mm-discouraged-alternatives'\) images or other material inside a +\"multipart/related\" part might be overlooked when this variable is nil." + :group 'gnus-article-mime + :type 'boolean) (defun gnus-mime-display-part (handle) (cond @@ -4591,11 +4657,9 @@ If no internal viewer is available, use an external viewer." (push (cons id handle) gnus-article-mime-handle-alist) (when (or (not display) (not (gnus-unbuttonized-mime-type-p type))) - ;(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) ;; Remember modify the number of forward lines. (setq move t)) (setq beg (point)) @@ -4683,7 +4747,7 @@ If no internal viewer is available, use an external viewer." ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',not-pref ',begend ,id)) - ,@(gnus-local-map-property gnus-mime-button-map) + keymap ,gnus-mime-button-map ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id @@ -4707,7 +4771,7 @@ If no internal viewer is available, use an external viewer." ',gnus-article-mime-handle-alist)) (gnus-mime-display-alternative ',ihandles ',handle ',begend ,id)) - ,@(gnus-local-map-property gnus-mime-button-map) + keymap ,gnus-mime-button-map ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id @@ -4722,8 +4786,8 @@ If no internal viewer is available, use an external viewer." (gnus-display-mime preferred) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) (mm-display-part preferred) ;; Do highlighting. (save-excursion @@ -4773,8 +4837,7 @@ is the string to use when it is inactive.") (defun gnus-article-wash-status () "Return a string which display status of article washing." - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((cite (memq 'cite gnus-article-wash-types)) (headers (memq 'headers gnus-article-wash-types)) (boring (memq 'boring-headers gnus-article-wash-types)) @@ -4813,7 +4876,7 @@ is the string to use when it is inactive.") "Delete all images in CATEGORY." (let ((entry (assq category gnus-article-image-alist))) (dolist (image (cdr entry)) - (gnus-remove-image image)) + (gnus-remove-image image category)) (setq gnus-article-image-alist (delq entry gnus-article-image-alist)) (gnus-delete-wash-type category))) @@ -4823,8 +4886,8 @@ is the string to use when it is inactive.") "Hide unwanted headers if `gnus-have-all-headers' is nil. Provided for backwards compatibility." (when (and (or (not (gnus-buffer-live-p gnus-summary-buffer)) - (not (save-excursion (set-buffer gnus-summary-buffer) - gnus-have-all-headers))) + (not (with-current-buffer gnus-summary-buffer + gnus-have-all-headers))) (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) @@ -4857,41 +4920,63 @@ If given a numerical ARG, move forward ARG pages." (let ((buffer-read-only nil)) (gnus-remove-text-with-property 'gnus-prev) (gnus-remove-text-with-property 'gnus-next))) - (when + (if (cond ((< arg 0) (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) ((> arg 0) (re-search-forward page-delimiter nil 'move arg))) - (goto-char (match-end 0))) - (narrow-to-region - (point) - (if (re-search-forward page-delimiter nil 'move) - (match-beginning 0) - (point))) - (when (and (gnus-visual-p 'page-marker) - (not (= (point-min) 1))) + (goto-char (match-end 0)) (save-excursion (goto-char (point-min)) - (gnus-insert-prev-page-button))) - (when (and (gnus-visual-p 'page-marker) - (< (+ (point-max) 2) (buffer-size))) - (save-excursion - (goto-char (point-max)) - (gnus-insert-next-page-button))))) + (setq gnus-page-broken + (and (re-search-forward page-delimiter nil t) t)))) + (when gnus-page-broken + (narrow-to-region + (point) + (if (re-search-forward page-delimiter nil 'move) + (match-beginning 0) + (point))) + (when (and (gnus-visual-p 'page-marker) + (not (= (point-min) 1))) + (save-excursion + (goto-char (point-min)) + (gnus-insert-prev-page-button))) + (when (and (gnus-visual-p 'page-marker) + (< (+ (point-max) 2) (buffer-size))) + (save-excursion + (goto-char (point-max)) + (gnus-insert-next-page-button)))))) ;; Article mode commands (defun gnus-article-goto-next-page () "Show the next page of the article." (interactive) - (gnus-eval-in-buffer-window gnus-summary-buffer - (gnus-summary-next-page))) + (when (gnus-article-next-page) + (goto-char (point-min)) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?n)))) + (defun gnus-article-goto-prev-page () - "Show the next page of the article." + "Show the previous page of the article." (interactive) - (gnus-eval-in-buffer-window gnus-summary-buffer - (gnus-summary-prev-page))) + (if (bobp) + (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) + (gnus-article-prev-page nil))) + +;; This is cleaner but currently breaks `gnus-pick-mode': +;; +;; (defun gnus-article-goto-next-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-next-page))) +;; +;; (defun gnus-article-goto-prev-page () +;; "Show the next page of the article." +;; (interactive) +;; (gnus-eval-in-buffer-window gnus-summary-buffer +;; (gnus-summary-prev-page))) (defun gnus-article-next-page (&optional lines) "Show the next page of the current article. @@ -4899,29 +4984,35 @@ If end of article, return non-nil. Otherwise return nil. Argument LINES specifies lines to be scrolled up." (interactive "p") (move-to-window-line -1) - (if (and (not gnus-article-over-scroll) - (save-excursion - (end-of-line) - (and (pos-visible-in-window-p) ;Not continuation line. - (>= (1+ (point)) (point-max))))) ;Allow for trailing newline. + (if (save-excursion + (end-of-line) + (and (pos-visible-in-window-p) ;Not continuation line. + (>= (1+ (point)) (point-max)))) ;Allow for trailing newline. ;; Nothing in this page. (if (or (not gnus-page-broken) (save-excursion (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. + (widen) + (eobp)))) ;Real end-of-buffer? + (progn + (when gnus-article-over-scroll + (gnus-article-next-page-1 lines)) + t) ;Nothing more. (gnus-narrow-to-page 1) ;Go to next page. nil) ;; More in this page. - (let ((scroll-in-place nil)) - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max))))) - (move-to-window-line 0) + (gnus-article-next-page-1 lines) nil)) +(defun gnus-article-next-page-1 (lines) + (let ((scroll-in-place nil)) + (condition-case () + (scroll-up lines) + (end-of-buffer + ;; Long lines may cause an end-of-buffer error. + (goto-char (point-max))))) + (move-to-window-line 0)) + (defun gnus-article-prev-page (&optional lines) "Show previous page of current article. Argument LINES specifies lines to be scrolled down." @@ -4963,9 +5054,9 @@ not have a face in `gnus-article-boring-faces'." "Read article specified by message-id around point." (interactive) (save-excursion - (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t) - (re-search-forward "]+" (gnus-point-at-eol) t) + (re-search-backward "[ \t]\\|^" (point-at-bol) t) + (re-search-forward "]+" (point-at-eol) t) (let ((msg-id (concat "<" (match-string 0) ">"))) (set-buffer gnus-summary-buffer) (gnus-summary-refer-article msg-id)) @@ -5059,11 +5150,13 @@ not have a face in `gnus-article-boring-faces'." (let ((obuf (current-buffer)) (owin (current-window-configuration)) (opoint (point)) - (summary gnus-article-current-summary) - func in-buffer selected) - (if not-restore-window - (pop-to-buffer summary 'norecord) - (switch-to-buffer summary 'norecord)) + win func in-buffer selected new-sum-start new-sum-hscroll) + (cond (not-restore-window + (pop-to-buffer gnus-article-current-summary 'norecord)) + ((setq win (get-buffer-window gnus-article-current-summary)) + (select-window win)) + (t + (switch-to-buffer gnus-article-current-summary 'norecord))) (setq in-buffer (current-buffer)) ;; We disable the pick minor mode commands. (if (and (setq func (let (gnus-pick-mode) @@ -5071,7 +5164,10 @@ not have a face in `gnus-article-boring-faces'." (functionp func)) (progn (call-interactively func) - (setq new-sum-point (point)) + (when (eq win (selected-window)) + (setq new-sum-point (point) + new-sum-start (window-start win) + new-sum-hscroll (window-hscroll win)) (when (eq in-buffer (current-buffer)) (setq selected (gnus-summary-select-article)) (set-buffer obuf) @@ -5083,10 +5179,12 @@ not have a face in `gnus-article-boring-faces'." 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) + (when (and (not not-restore-window) + new-sum-point) + (set-window-point win new-sum-point) + (set-window-start win new-sum-start) + (set-window-hscroll win new-sum-hscroll))))) + (set-window-configuration owin) (ding)))))) (defun gnus-article-describe-key (key) @@ -5138,7 +5236,7 @@ the entire article will be yanked." (interactive "P") (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-reply (list (list article)) wide)) (setq contents (buffer-substring (point) (mark t))) @@ -5157,7 +5255,7 @@ the entire article will be yanked." (interactive) (let ((article (cdr gnus-article-current)) contents) - (if (not (gnus-mark-active-p)) + (if (not (gnus-region-active-p)) (with-current-buffer gnus-summary-buffer (gnus-summary-followup (list (list article)))) (setq contents (buffer-substring (point) (mark t))) @@ -5257,16 +5355,14 @@ If given a prefix, show the hidden text instead." gnus-summary-buffer (get-buffer gnus-summary-buffer) (gnus-buffer-exists-p gnus-summary-buffer) - (eq (cdr (save-excursion - (set-buffer gnus-summary-buffer) + (eq (cdr (with-current-buffer gnus-summary-buffer (assq article gnus-newsgroup-reads))) gnus-canceled-mark)) nil) ;; We first check `gnus-original-article-buffer'. ((and (get-buffer gnus-original-article-buffer) (numberp article) - (save-excursion - (set-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (and (equal (car gnus-original-article) group) (eq (cdr gnus-original-article) article)))) (insert-buffer-substring gnus-original-article-buffer) @@ -5384,7 +5480,6 @@ If given a prefix, show the hidden text instead." (defvar gnus-article-edit-done-function nil) (defvar gnus-article-edit-mode-map nil) -(defvar gnus-article-edit-mode nil) ;; Should we be using derived.el for this? (unless gnus-article-edit-mode-map @@ -5521,12 +5616,13 @@ groups." (car gnus-article-current) (cdr gnus-article-current))) ;; We remove all text props from the article buffer. (kill-all-local-variables) - (gnus-set-text-properties (point-min) (point-max) nil) + (set-text-properties (point-min) (point-max) nil) (gnus-article-mode) (set-window-configuration winconf) (set-buffer buf) (set-window-start (get-buffer-window buf) start) - (set-window-point (get-buffer-window buf) (point)))) + (set-window-point (get-buffer-window buf) (point))) + (gnus-summary-show-article)) (defun gnus-article-edit-exit () "Exit the article editing without updating." @@ -5547,7 +5643,8 @@ groups." (save-current-buffer (set-buffer curbuf) (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p)))))) + (goto-char p)))) + (gnus-summary-show-article))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -5568,8 +5665,8 @@ groups." (defcustom gnus-button-url-regexp (if (string-match "[[:digit:]]" "1") ;; support POSIX? - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" - "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)" + "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)") "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) @@ -5616,7 +5713,7 @@ The function must take one argument, the string naming the URL." (defcustom gnus-button-ctan-directory-regexp (concat - "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20). + "\\(?:" "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|" "indexing\\|info\\|language\\|macros\\|support\\|systems\\|" "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete" @@ -5627,7 +5724,8 @@ It should match all directories in the top level of `gnus-ctan-url'." :type 'regexp) (defcustom gnus-button-mid-or-mail-regexp - (concat "\\b\\(\")!;:,{}\n\t ]*@" + (concat "\\b\\(\")!;:,{}\n\t ]*@" + ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de> gnus-button-valid-fqdn-regexp ">?\\)\\b") "Regular expression that matches a message ID or a mail address." @@ -5638,7 +5736,7 @@ It should match all directories in the top level of `gnus-ctan-url'." "What to do when the button on a string as \"foo123@bar.invalid\" is pushed. Strings like this can be either a message ID or a mail address. If it is one of the symbols `mid' or `mail', Gnus will always assume that the string is a -message ID or a mail address, respectivly. If this variable is set to the +message ID or a mail address, respectively. If this variable is set to the symbol `ask', always query the user what do do. If it is a function, this function will be called with the string as it's only argument. The function must return `mid', `mail', `invalid' or `ask'." @@ -5704,7 +5802,7 @@ must return `mid', `mail', `invalid' or `ask'." "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'. A negative RATE indicates a message IDs, whereas a positive indicates a mail -address. The REGEXP is processed with `case-fold-search' set to `nil'." +address. The REGEXP is processed with `case-fold-search' set to nil." :group 'gnus-article-buttons :type '(repeat (cons (number :tag "Rate") (regexp :tag "Regexp")))) @@ -5722,13 +5820,14 @@ address, `ask' if unsure and `invalid' if the string is invalid." ;; Certain special cases... (when (string-match (concat - "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$" "\\|" - "^[0-9]+\.[0-9]+\@compuserve") + "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|" + "^[0-9]+\\.[0-9]+@compuserve\\|" + "@public\\.gmane\\.org") mid-or-mail) - (gnus-message 8 "`%s' is a known mail address.") + (gnus-message 8 "`%s' is a known mail address." mid-or-mail) (setq result 'mail)) (when (string-match "@.*@\\| " mid-or-mail) - (gnus-message 8 "`%s' is invalid.") + (gnus-message 8 "`%s' is invalid." mid-or-mail) (setq result 'invalid)) ;; Nothing more to do, if result is not a number here... (when (numberp result) @@ -5770,8 +5869,10 @@ address, `ask' if unsure and `invalid' if the string is invalid." (gnus-message 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result))))) (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result) + ;; Maybe we should make this a customizable alist: (condition . 'result) (cond - ;; Maybe we should make this a customizable alist: (condition . 'result) + ((symbolp result) result) + ;; Now convert number into proper results: ((< result -10.0) 'mid) ((> result 10.0) 'mail) (t 'ask)))) @@ -5883,7 +5984,7 @@ Calls `describe-variable' or `describe-function'." "*Integer that says how many TeX-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in TeX groups is probably a good idea. +specific groups. Setting it higher in TeX groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons @@ -5894,7 +5995,7 @@ how to set variables in specific groups." "*Integer that says how many man-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in Unix groups is probably a good idea. +specific groups. Setting it higher in Unix groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons @@ -5905,7 +6006,7 @@ how to set variables in specific groups." "*Integer that says how many emacs-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false positives are possible. Note that you can set this variable local to -specifific groups. Setting it higher in Emacs or Gnus related groups is +specific groups. Setting it higher in Emacs or Gnus related groups is probably a good idea. See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on how to set variables in specific groups." :group 'gnus-article-buttons @@ -5933,20 +6034,26 @@ positives are possible." 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3) ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-handle-news 2) - ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" - 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 4) - ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" - 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 2) + ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5) + ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3) + ;; RFC 2392 (Don't allow `/' in domain part --> CID) + ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)" + 0 (>= gnus-button-message-level 0) gnus-button-message-id 2) ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 (>= gnus-button-message-level 0) gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 (>= gnus-button-message-level 0) gnus-url-mailto 2) - ("mailto:\\([-a-z.@_+0-9%=?]+\\)" + ;; RFC 2368 (The mailto URL scheme) + ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ;; CTAN - ("\\bCTAN:[ \t\n]*\\([^>)!;:,'\n\t ]*\\)" + ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" + gnus-button-ctan-directory-regexp + "[^][>)!;:,'\n\t ]+\\)") 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) ((concat "\\btex-archive/\\(" gnus-button-ctan-directory-regexp @@ -5957,9 +6064,15 @@ positives are possible." gnus-button-ctan-directory-regexp "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) - ;; This is info - ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" - 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) + ;; This is info (home-grown style) + ("\\binfo://\\([^'\">\n\t ]+\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) + ;; Info GNOME style + ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1) + ;; Info KDE style + ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>" + 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) ("\\b\\(C-h\\|?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" @@ -5986,12 +6099,14 @@ positives are possible." 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) ("`\\([a-z][-a-z0-9]+\\.el\\)'" 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1) - ("`\\([a-z]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" + ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'" 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1) - ("`\\([a-z]+-[a-z]+\\)'" + ("`\\([a-z][a-z0-9]+-[a-z]+\\)'" 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1) ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)" 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1) + ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" + 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1) ("\\b\\(C-h\\|?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2) ("\\b\\(C-h\\|?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET" @@ -6000,23 +6115,29 @@ positives are possible." ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) - ;; This is how URLs _should_ be embedded in text (RFC 1738)... + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... ("]*\\)>" 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) ;; Raw URLs. (gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) ;; man pages - ("\\b\\([a-z][a-z]+\\)([1-9])\\W" + ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) gnus-button-handle-man 1) ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x) - ("\\b\\([a-z][-_.a-z0-9]+\\)([1-9])\\W" + ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5)) gnus-button-handle-man 1) ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm), ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7) - ("\\b\\([a-z][-_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W" + ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\W\\|\\b\\(?:X([1-9])\\)\\)\\W" 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1) ;; MID or mail: To avoid too many false positives we don't try to catch ;; all kind of allowed MIDs or mail addresses. Domain part must contain @@ -6029,9 +6150,9 @@ positives are possible." Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string (case insensitive) matching text around the button (can -also be lisp expression evaluating to a string), +also be Lisp expression evaluating to a string), BUTTON: is the number of the regexp grouping actually matching the button, -FORM: is a lisp expression which must eval to true for the button to +FORM: is a Lisp expression which must eval to true for the button to be added, CALLBACK: is the function to call when the user push this button, and each PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. @@ -6039,7 +6160,7 @@ PAR: is a number of a regexp grouping whose text will be passed to CALLBACK. CALLBACK can also be a variable, in that case the value of that variable it the real callback function." :group 'gnus-article-buttons - :type '(repeat (list (choice regexp variable) + :type '(repeat (list (choice regexp variable sexp) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -6048,7 +6169,7 @@ variable it the real callback function." (integer :tag "Regexp group"))))) (defcustom gnus-header-button-alist - '(("^\\(References\\|Message-I[Dd]\\):" "<[^<>]+>" + '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>" 0 (>= gnus-button-message-level 0) gnus-button-message-id 0) ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 (>= gnus-button-message-level 0) gnus-button-reply 1) @@ -6060,10 +6181,10 @@ variable it the real callback function." 0 (>= gnus-button-browse-level 0) browse-url 0) ("^[^:]+:" gnus-button-url-regexp 0 (>= gnus-button-browse-level 0) browse-url 0) - ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?]+\\)" + ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) - ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" - 1 (>= gnus-button-message-level 0) gnus-button-message-id 3)) + ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)" + 1 (>= gnus-button-message-level 0) gnus-button-message-id 4)) "*Alist of headers and regexps to match buttons in article heads. This alist is very similar to `gnus-button-alist', except that each @@ -6076,7 +6197,7 @@ HEADER is a regexp to match a header. For a fuller explanation, see :group 'gnus-article-buttons :group 'gnus-article-headers :type '(repeat (list (regexp :tag "Header") - regexp + (choice regexp variable) (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -6084,13 +6205,6 @@ HEADER is a regexp to match a header. For a fuller explanation, see :inline t (integer :tag "Regexp group"))))) -(defvar gnus-button-regexp nil) -(defvar gnus-button-marker-list nil) -;; Regexp matching any of the regexps from `gnus-button-alist'. - -(defvar gnus-button-last nil) -;; The value of `gnus-button-alist' when `gnus-button-regexp' was build. - ;;; Commands: (defun gnus-article-push-button (event) @@ -6142,51 +6256,43 @@ do the highlighting. See the documentation for those functions." (defun gnus-article-highlight-headers () "Highlight article headers as specified by `gnus-header-face-alist'." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((alist gnus-header-face-alist) - (buffer-read-only nil) - (case-fold-search t) - (inhibit-point-motion-hooks t) - entry regexp header-face field-face from hpoints fpoints) - (article-narrow-to-head) - (while (setq entry (pop alist)) - (goto-char (point-min)) - (setq regexp (concat "^\\(" - (if (string-equal "" (nth 0 entry)) - "[^\t ]" - (nth 0 entry)) - "\\)") - header-face (nth 1 entry) - field-face (nth 2 entry)) - (while (and (re-search-forward regexp nil t) - (not (eobp))) - (beginning-of-line) - (setq from (point)) - (unless (search-forward ":" nil t) - (forward-char 1)) - (when (and header-face - (not (memq (point) hpoints))) - (push (point) hpoints) - (gnus-put-text-property from (point) 'face header-face)) - (when (and field-face - (not (memq (setq from (point)) fpoints))) - (push from fpoints) - (if (re-search-forward "^[^ \t]" nil t) - (forward-char -2) - (goto-char (point-max))) - (gnus-put-text-property from (point) 'face field-face)))))))) + (gnus-with-article-headers + (let ((alist gnus-header-face-alist) + entry regexp header-face field-face from hpoints fpoints) + (while (setq entry (pop alist)) + (goto-char (point-min)) + (setq regexp (concat "^\\(" + (if (string-equal "" (nth 0 entry)) + "[^\t ]" + (nth 0 entry)) + "\\)") + header-face (nth 1 entry) + field-face (nth 2 entry)) + (while (and (re-search-forward regexp nil t) + (not (eobp))) + (beginning-of-line) + (setq from (point)) + (unless (search-forward ":" nil t) + (forward-char 1)) + (when (and header-face + (not (memq (point) hpoints))) + (push (point) hpoints) + (gnus-put-text-property from (point) 'face header-face)) + (when (and field-face + (not (memq (setq from (point)) fpoints))) + (push from fpoints) + (if (re-search-forward "^[^ \t]" nil t) + (forward-char -2) + (goto-char (point-max))) + (gnus-put-text-property from (point) 'face field-face))))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. It does this by highlighting everything after `gnus-signature-separator' using `gnus-signature-face'." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t)) (save-restriction (when (and gnus-signature-face (gnus-article-narrow-to-signature)) @@ -6208,10 +6314,8 @@ It does this by highlighting everything after \"External references\" are things like Message-IDs and URLs, as specified by `gnus-button-alist'." (interactive (list 'force)) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-button-alist) beg entry regexp) @@ -6252,40 +6356,33 @@ specified by `gnus-button-alist'." (defun gnus-article-add-buttons-to-head () "Add buttons to the head of the article." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) - (save-restriction - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t) - (case-fold-search t) - (alist gnus-header-button-alist) - entry beg end) - (article-narrow-to-head) - (while alist - ;; Each alist entry. - (setq entry (car alist) - alist (cdr alist)) - (goto-char (point-min)) - (while (re-search-forward (car entry) nil t) - ;; Each header matching the entry. - (setq beg (match-beginning 0)) - (setq end (or (and (re-search-forward "^[^ \t]" nil t) - (match-beginning 0)) - (point-max))) - (goto-char beg) - (while (re-search-forward (eval (nth 1 entry)) end t) - ;; Each match within a header. - (let* ((entry (cdr entry)) - (start (match-beginning (nth 1 entry))) - (end (match-end (nth 1 entry))) - (form (nth 2 entry))) - (goto-char (match-end 0)) - (when (eval form) - (gnus-article-add-button - start end (nth 3 entry) - (buffer-substring (match-beginning (nth 4 entry)) - (match-end (nth 4 entry))))))) - (goto-char end))))))) + (gnus-with-article-headers + (let ((alist gnus-header-button-alist) + entry beg end) + (while alist + ;; Each alist entry. + (setq entry (pop alist)) + (goto-char (point-min)) + (while (re-search-forward (car entry) nil t) + ;; Each header matching the entry. + (setq beg (match-beginning 0)) + (setq end (or (and (re-search-forward "^[^ \t]" nil t) + (match-beginning 0)) + (point-max))) + (goto-char beg) + (while (re-search-forward (eval (nth 1 entry)) end t) + ;; Each match within a header. + (let* ((entry (cdr entry)) + (start (match-beginning (nth 1 entry))) + (end (match-end (nth 1 entry))) + (form (nth 2 entry))) + (goto-char (match-end 0)) + (when (eval form) + (gnus-article-add-button + start end (nth 3 entry) + (buffer-substring (match-beginning (nth 4 entry)) + (match-end (nth 4 entry))))))) + (goto-char end)))))) ;;; External functions: @@ -6306,15 +6403,12 @@ specified by `gnus-button-alist'." ;;; Internal functions: (defun gnus-article-set-globals () - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-set-global-variables))) (defun gnus-signature-toggle (end) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) + (gnus-with-article-buffer + (let ((inhibit-point-motion-hooks t)) (if (text-property-any end (point-max) 'article-type 'signature) (progn (gnus-delete-wash-type 'signature) @@ -6350,7 +6444,7 @@ specified by `gnus-button-alist'." (fun (nth 3 entry)) (args (mapcar (lambda (group) (let ((string (match-string group))) - (gnus-set-text-properties + (set-text-properties 0 (length string) nil string) string)) (nthcdr 4 entry)))) @@ -6405,10 +6499,15 @@ specified by `gnus-button-alist'." (defun gnus-button-handle-man (url) "Fetch a man page." + (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) + (when (eq gnus-button-man-handler 'woman) + (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" ""))) + (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url) (funcall gnus-button-man-handler url)) (defun gnus-button-handle-info-url (url) "Fetch an info URL." + (setq url (mm-subst-char-in-string ?+ ?\ url)) (cond ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url) (gnus-info-find-node @@ -6422,6 +6521,24 @@ specified by `gnus-button-alist'." (gnus-info-find-node url)) (t (error "Can't parse %s" url)))) +(defun gnus-button-handle-info-url-gnome (url) + "Fetch GNOME style info URL." + (setq url (mm-subst-char-in-string ?_ ?\ url)) + (if (string-match "\\([^#]+\\)#?\\(.*\\)" url) + (gnus-info-find-node + (concat "(" + (gnus-url-unhex-string + (match-string 1 url)) + ")" + (or (gnus-url-unhex-string + (match-string 2 url)) + "Top"))) + (error "Can't parse %s" url))) + +(defun gnus-button-handle-info-url-kde (url) + "Fetch KDE style info URL." + (gnus-info-find-node (gnus-url-unhex-string url))) + (defun gnus-button-handle-info-keystrokes (url) "Call `info' when pushing the corresponding URL button." ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. @@ -6431,8 +6548,7 @@ specified by `gnus-button-alist'." (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (gnus-summary-refer-article message-id))) (defun gnus-button-fetch-group (address) @@ -6478,12 +6594,14 @@ specified by `gnus-button-alist'." (when (string-match "mailto:/*\\(.*\\)" url) (setq url (substring url (match-beginning 1) nil))) (let (to args subject func) - (if (string-match (regexp-quote "?") url) - (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0))) - args (gnus-url-parse-query-string - (substring url (match-end 0) nil) t)) - (setq to (gnus-url-unhex-string url))) - (setq args (cons (list "to" to) args) + (setq args (gnus-url-parse-query-string + (if (string-match "^\\?" url) + (substring url 1) + (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url) + (concat "to=" (match-string 1 url) "&" + (match-string 2 url)) + (concat "to=" url))) + t) subject (cdr-safe (assoc "subject" args))) (gnus-msg-mail) (while args @@ -6491,7 +6609,9 @@ specified by `gnus-button-alist'." (if (fboundp func) (funcall func) (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) + (insert (gnus-replace-in-string + (mapconcat 'identity (reverse (cdar args)) ", ") + "\r\n" "\n" t)) (setq args (cdr args))) (if subject (message-goto-body) @@ -6508,19 +6628,22 @@ specified by `gnus-button-alist'." (defvar gnus-prev-page-map (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-button-prev-page) (define-key map "\r" 'gnus-button-prev-page) map)) +(defvar gnus-next-page-map + (let ((map (make-sparse-keymap))) + (define-key map gnus-mouse-2 'gnus-button-next-page) + (define-key map "\r" 'gnus-button-next-page) + map)) + (defun gnus-insert-prev-page-button () (let ((b (point)) (buffer-read-only nil)) (gnus-eval-format gnus-prev-page-line-format nil - `(,@(gnus-local-map-property gnus-prev-page-map) + `(keymap ,gnus-prev-page-map gnus-prev t gnus-callback gnus-article-button-prev-page article-type annotation)) @@ -6532,24 +6655,6 @@ specified by `gnus-button-alist'." :action 'gnus-button-prev-page :button-keymap gnus-prev-page-map))) -(defvar gnus-prev-page-map - (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) - (define-key map gnus-mouse-2 'gnus-button-prev-page) - (define-key map "\r" 'gnus-button-prev-page) - map)) - -(defvar gnus-next-page-map - (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) - (define-key map gnus-mouse-2 'gnus-button-next-page) - (define-key map "\r" 'gnus-button-next-page) - map)) - (defun gnus-button-next-page (&optional args more-args) "Go to the next page." (interactive) @@ -6570,7 +6675,7 @@ specified by `gnus-button-alist'." (let ((b (point)) (buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil - `(,@(gnus-local-map-property gnus-next-page-map) + `(keymap ,gnus-next-page-map gnus-next t gnus-callback gnus-article-button-next-page article-type annotation)) @@ -6604,7 +6709,7 @@ specified by `gnus-button-alist'." This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a -\(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups +\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups whose names match REGEXP. For example: @@ -6806,8 +6911,6 @@ For example: (defvar gnus-mime-security-button-map (let ((map (make-sparse-keymap))) - (unless (>= (string-to-number emacs-version) 21) - (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)) @@ -6914,7 +7017,7 @@ For example: (gnus-eval-format gnus-mime-security-button-line-format gnus-mime-security-button-line-format-alist - `(,@(gnus-local-map-property gnus-mime-security-button-map) + `(keymap ,gnus-mime-security-button-map gnus-callback gnus-mime-security-press-button gnus-line-format ,gnus-mime-security-button-line-format gnus-mime-details ,gnus-mime-security-button-pressed