X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=5b54196a518a034b3aba3180d8237283294bee6a;hb=507b285173baa14c25dc095f5c65d05a5474a8fe;hp=68e00d27091a642abdbbdce2f69d2e21d79a549f;hpb=cb7891a6614b1094a44036775fb6520b9992de79;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 68e00d270..5b54196a5 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -92,7 +92,7 @@ '("^Path:" "^Posting-Version:" "^Article-I.D.:" "^Expires:" "^Date-Received:" "^References:" "^Control:" "^Xref:" "^Lines:" "^Posted:" "^Relay-Version:" "^Message-ID:" "^Nf-ID:" "^Nf-From:" - "^Approved:" "^Sender:" "^Received:" "^Mail-from:") + "^Approved:" "^Sender:" "^Received:" "^Mail-from:") "All headers that match 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." @@ -101,7 +101,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." (repeat regexp)) :group 'gnus-article-hiding) -(defcustom gnus-visible-headers +(defcustom gnus-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From" "All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. @@ -156,7 +156,7 @@ regexp. If it matches, the text in question is not a signature." (defcustom gnus-hidden-properties '(invisible t intangible t) "Property list to use for hiding text." - :type 'sexp + :type 'sexp :group 'gnus-article-hiding) (defcustom gnus-article-x-face-command @@ -179,11 +179,10 @@ asynchronously. The compressed face will be piped to this command." '(("_" "_" underline) ("/" "/" italic) ("\\*" "\\*" bold) - ;;("_/" "/_" underline-italic) - ;;("_\\*" "\\*_" underline-bold) + ("_/" "/_" underline-italic) + ("_\\*" "\\*_" underline-bold) ("\\*/" "/\\*" bold-italic) - ;;("_\\*/" "/\\*_" underline-bold-italic) - ))) + ("_\\*/" "/\\*_" underline-bold-italic)))) `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 2 3 gnus-emphasis-underline) ,@(mapcar @@ -233,7 +232,7 @@ is the face used for highlighting." "Face used for displaying bold italic emphasized text (/*word*/)." :group 'gnus-article-emphasis) -(defface gnus-emphasis-underline-bold-italic +(defface gnus-emphasis-underline-bold-italic '((t (:bold t :italic t :underline t))) "Face used for displaying underlined bold italic emphasized text. Esample: (_/*word*/_)." @@ -251,11 +250,6 @@ See `format-time-zone' for the possible values." (autoload 'timezone-make-date-arpa-standard "timezone") (autoload 'mail-extract-address-components "mail-extr")) -(defcustom gnus-article-save-directory gnus-directory - "*Name of the directory articles will be saved in (default \"~/News\")." - :group 'gnus-article-saving - :type 'directory) - (defcustom gnus-save-all-headers t "*If non-nil, don't remove any headers before saving." :group 'gnus-article-saving @@ -422,53 +416,53 @@ above them." :group 'gnus-article-highlight :group 'gnus-article-signature) -(defface gnus-header-from-face +(defface gnus-header-from-face '((((class color) (background dark)) - (:foreground "light blue" :bold t :italic t)) + (:foreground "spring green" :bold t)) (((class color) (background light)) - (:foreground "MidnightBlue" :bold t :italic t)) - (t + (:foreground "red3" :bold t)) + (t (:bold t :italic t))) "Face used for displaying from headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -(defface gnus-header-subject-face +(defface gnus-header-subject-face '((((class color) (background dark)) - (:foreground "pink" :bold t :italic t)) + (:foreground "SeaGreen3" :bold t)) (((class color) (background light)) - (:foreground "firebrick" :bold t :italic t)) - (t + (:foreground "red4" :bold t)) + (t (:bold t :italic t))) "Face used for displaying subject headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -(defface gnus-header-newsgroups-face +(defface gnus-header-newsgroups-face '((((class color) (background dark)) (:foreground "yellow" :bold t :italic t)) (((class color) (background light)) - (:foreground "indianred" :bold t :italic t)) - (t + (:foreground "MidnightBlue" :bold t :italic t)) + (t (:bold t :italic t))) "Face used for displaying newsgroups headers." :group 'gnus-article-headers :group 'gnus-article-highlight) -(defface gnus-header-name-face +(defface gnus-header-name-face '((((class color) (background dark)) - (:foreground "cyan" :bold t)) + (:foreground "SeaGreen")) (((class color) (background light)) - (:foreground "DarkGreen" :bold t)) - (t + (:foreground "maroon")) + (t (:bold t))) "Face used for displaying header names." :group 'gnus-article-headers @@ -480,8 +474,8 @@ above them." (:foreground "forest green" :italic t)) (((class color) (background light)) - (:foreground "DarkGreen" :italic t)) - (t + (:foreground "indianred4" :italic t)) + (t (:italic t))) "Face used for displaying header content." :group 'gnus-article-headers :group 'gnus-article-highlight) @@ -493,7 +487,7 @@ above them." ("" gnus-header-name-face gnus-header-content-face)) "Controls highlighting of article header. -An alist of the form (HEADER NAME CONTENT). +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. @@ -516,7 +510,7 @@ displayed by the first non-nil matching CONTENT face." (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) - ;;(modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?- "w" table) table) "Syntax table used in article mode buffers. Initialized from `text-mode-syntax-table.") @@ -536,7 +530,7 @@ Initialized from `text-mode-syntax-table.") "Set text PROPS on the B to E region, extending `intangible' 1 past B." (add-text-properties b e props) (when (memq 'intangible props) - (put-text-property + (put-text-property (max (1- b) (point-min)) b 'intangible (cddr (memq 'intangible props))))) @@ -651,16 +645,16 @@ always hide." (while (re-search-forward "^[^ \t]*:" nil t) (beginning-of-line) ;; Mark the rank of the header. - (put-text-property + (put-text-property (point) (1+ (point)) 'message-rank (if (or (and visible (looking-at visible)) (and ignored (not (looking-at ignored)))) - (gnus-article-header-rank) + (gnus-article-header-rank) (+ 2 max))) (forward-line 1)) (message-sort-headers-1) - (when (setq beg (text-property-any + (when (setq beg (text-property-any (point-min) (point-max) 'message-rank (+ 2 max))) ;; We make the unwanted headers invisible. (if delete @@ -694,7 +688,7 @@ always hide." (forward-line -1) (gnus-article-hide-text-type (progn (beginning-of-line) (point)) - (progn + (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) (match-beginning 0) @@ -718,7 +712,7 @@ always hide." (when (and from reply-to (ignore-errors - (equal + (equal (nth 1 (mail-extract-address-components from)) (nth 1 (mail-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) @@ -735,7 +729,7 @@ always hide." (when (re-search-forward (concat "^" header ":") nil t) (gnus-article-hide-text-type (progn (beginning-of-line) (point)) - (progn + (progn (end-of-line) (if (re-search-forward "^[^ \t]" nil t) (match-beginning 0) @@ -754,7 +748,7 @@ always hide." ;; We do the boldification/underlining by hiding the ;; overstrikes and putting the proper text property ;; on the letters. - (cond + (cond ((eq next previous) (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) (put-text-property (point) (1+ (point)) 'face 'bold)) @@ -864,14 +858,14 @@ always hide." (goto-char (point-min)) (or (search-forward "\n\n" nil t) (point-max))) (goto-char (point-min)) - (while (re-search-forward + (while (re-search-forward "=\\?iso-8859-1\\?q\\?\\([^?\t\n]*\\)\\?=" nil t) (setq string (match-string 1)) (save-restriction (narrow-to-region (match-beginning 0) (match-end 0)) (delete-region (point-min) (point-max)) (insert string) - (article-mime-decode-quoted-printable + (article-mime-decode-quoted-printable (goto-char (point-min)) (point-max)) (subst-char-in-region (point-min) (point-max) ?_ ? ) (goto-char (point-max))) @@ -899,7 +893,7 @@ or not." (defun article-mime-decode-quoted-printable-buffer () "Decode Quoted-Printable in the current buffer." (article-mime-decode-quoted-printable (point-min) (point-max))) - + (defun article-mime-decode-quoted-printable (from to) "Decode Quoted-Printable in the region between FROM and TO." (interactive "r") @@ -931,7 +925,8 @@ always hide." (goto-char (point-min)) ;; Hide the "header". (when (search-forward "\n-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) - (gnus-article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) + (gnus-article-hide-text-type (1+ (match-beginning 0)) + (match-end 0) 'pgp)) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) @@ -949,7 +944,7 @@ always hide." (narrow-to-region beg end) (goto-char (point-min)) (while (re-search-forward "^- " nil t) - (gnus-article-hide-text-type + (gnus-article-hide-text-type (match-beginning 0) (match-end 0) 'pgp)) (widen)))))) @@ -991,7 +986,7 @@ always hide." (save-restriction (let ((buffer-read-only nil)) (when (gnus-article-narrow-to-signature) - (gnus-article-hide-text-type + (gnus-article-hide-text-type (point-min) (point-max) 'signature))))))) (defun article-strip-leading-blank-lines () @@ -1010,16 +1005,30 @@ always hide." "Replace consecutive blank lines with one empty line." (interactive) (save-excursion - (let (buffer-read-only) + (let ((inhibit-point-motion-hooks t) + buffer-read-only) ;; First make all blank lines empty. (goto-char (point-min)) + (search-forward "\n\n" nil t) (while (re-search-forward "^[ \t]+$" nil t) (replace-match "" nil t)) ;; Then replace multiple empty lines with a single empty line. (goto-char (point-min)) + (search-forward "\n\n" nil t) (while (re-search-forward "\n\n\n+" nil t) (replace-match "\n\n" t t))))) +(defun article-strip-leading-space () + "Remove all white space from the beginning of the lines in the article." + (interactive) + (save-excursion + (let ((inhibit-point-motion-hooks t) + buffer-read-only) + (goto-char (point-min)) + (search-forward "\n\n" nil t) + (while (re-search-forward "^[ \t]+" nil t) + (replace-match "" t t))))) + (defun article-strip-blank-lines () "Strip leading, trailing and multiple blank lines." (interactive) @@ -1040,7 +1049,7 @@ always hide." (narrow-to-region (funcall (intern "mime::preview-content-info/point-min") pcinfo) (point-max))))) - + (when (gnus-article-search-signature) (forward-line 1) ;; Check whether we have some limits to what we consider @@ -1080,6 +1089,34 @@ Put point at the beginning of the signature separator." (goto-char cur) nil))) +(eval-and-compile + (autoload 'w3-parse-buffer "w3-parse")) + +(defun gnus-article-treat-html () + "Render HTML." + (interactive) + (let ((cbuf (current-buffer))) + (set-buffer gnus-article-buffer) + (let (buf buffer-read-only b e) + (goto-char (point-min)) + (narrow-to-region + (if (search-forward "\n\n" nil t) + (setq b (point)) + (point-max)) + (setq e (point-max))) + (nnheader-temp-write nil + (insert-buffer-substring gnus-article-buffer b e) + (save-window-excursion + (setq buf (car (w3-parse-buffer (current-buffer)))))) + (when buf + (delete-region (point-min) (point-max)) + (insert-buffer-substring buf) + (kill-buffer buf)) + (widen) + (goto-char (point-min)) + (set-window-start (get-buffer-window (current-buffer)) (point-min)) + (set-buffer cbuf)))) + (defun gnus-article-hidden-arg () "Return the current prefix arg as a number, or 0 if no prefix." (list (if current-prefix-arg @@ -1146,7 +1183,7 @@ If HIDE, hide the text instead." If TYPE is `local', convert to local time; if it is `lapsed', output how much time has lapsed since DATE." (interactive (list 'ut t)) - (let* ((header (or header + (let* ((header (or header (mail-header-date gnus-current-headers) (message-fetch-field "date") "")) @@ -1202,7 +1239,8 @@ how much time has lapsed since DATE." (concat "Date: " date "\n")) ;; Let the user define the format. ((eq type 'user) - (concat + (concat + "Date: " (format-time-string gnus-article-time-format (ignore-errors (gnus-encode-date @@ -1252,7 +1290,7 @@ how much time has lapsed since DATE." (prog1 (concat (if prev ", " "") (int-to-string (floor num)) - " " (symbol-name (car unit)) + " " (symbol-name (car unit)) (if (> num 1) "s" "")) (setq prev t)))) article-time-units "") @@ -1282,7 +1320,8 @@ function and want to see what the date was before converting." (article-date-ut 'lapsed highlight)) (defun article-date-user (&optional highlight) - "Convert the current article date to the user-defined format." + "Convert the current article date to the user-defined format. +This format is defined by the `gnus-article-time-format' variable." (interactive (list t)) (article-date-ut 'user highlight)) @@ -1352,7 +1391,7 @@ function and want to see what the date was before converting." (when (eq gnus-prompt-before-saving t) num))) ; Magic (set-buffer gnus-summary-buffer) - (funcall gnus-default-article-saver filename))))) + (funcall gnus-default-article-saver filename))))) (defun gnus-read-save-file-name (prompt default-name &optional filename) (cond @@ -1524,7 +1563,7 @@ The directory to save in defaults to `gnus-article-save-directory'." (cond ((eq command 'default) gnus-last-shell-command) (command command) - (t (read-string + (t (read-string (format "Shell command on %s: " (if (and gnus-number-of-articles-to-be-saved @@ -1616,7 +1655,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is gfunc (cdr func)) (setq afunc func gfunc (intern (format "gnus-%s" func)))) - (fset gfunc + (fset gfunc (if (not (fboundp afunc)) nil `(lambda (&optional interactive &rest args) @@ -1641,6 +1680,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-remove-trailing-blank-lines article-strip-leading-blank-lines article-strip-multiple-blank-lines + article-strip-leading-space article-strip-blank-lines article-date-local article-date-original @@ -1746,6 +1786,7 @@ commands: (use-local-map gnus-article-mode-map) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) + (set (make-local-variable 'gnus-button-marker-list) nil) (gnus-set-default-directory) (buffer-disable-undo (current-buffer)) (setq buffer-read-only t) @@ -2010,6 +2051,7 @@ If given a numerical ARG, move forward ARG pages." "Show the next page of the article." (interactive) (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 () @@ -2060,8 +2102,10 @@ Argument LINES specifies lines to be scrolled down." (recenter -1)) (let ((scroll-in-place nil)) (prog1 - (ignore-errors - (scroll-down lines)) + (condition-case () + (scroll-down lines) + (beginning-of-buffer + (goto-char (point-min)))) (move-to-window-line 0))))) (defun gnus-article-refer-article () @@ -2214,7 +2258,7 @@ If given a prefix, show the hidden text instead." (set-buffer gnus-summary-buffer) (let ((header (gnus-summary-article-header article))) (when (< article 0) - (cond + (cond ((memq article gnus-newsgroup-sparse) ;; This is a sparse gap article. (setq do-update-line article) @@ -2230,8 +2274,8 @@ If given a prefix, show the hidden text instead." ;; It is an extracted pseudo-article. (setq article 'pseudo) (gnus-request-pseudo-article header)))) - - (let ((method (gnus-find-method-for-group + + (let ((method (gnus-find-method-for-group gnus-newsgroup-name))) (if (not (eq (car method) 'nneething)) () @@ -2285,7 +2329,7 @@ If given a prefix, show the hidden text instead." (when (numberp article) (gnus-async-prefetch-next group article gnus-summary-buffer) (when gnus-keep-backlog - (gnus-backlog-enter-article + (gnus-backlog-enter-article group article (current-buffer)))) 'article))) ;; It was a pseudo. @@ -2309,7 +2353,7 @@ If given a prefix, show the hidden text instead." (erase-buffer) (insert-buffer-substring gnus-article-buffer)) (setq gnus-original-article (cons group article)))) - + ;; Update sparse articles. (when (and do-update-line (or (numberp article) @@ -2335,7 +2379,7 @@ If given a prefix, show the hidden text instead." (defvar gnus-article-edit-mode-map nil) -(unless gnus-article-edit-mode-map +(unless gnus-article-edit-mode-map (setq gnus-article-edit-mode-map (copy-keymap text-mode-map)) (gnus-define-keys gnus-article-edit-mode-map @@ -2418,10 +2462,10 @@ groups." (gnus-article-mode) ;; The cache and backlog have to be flushed somewhat. (when gnus-use-cache - (gnus-cache-update-article + (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current))) (when gnus-keep-backlog - (gnus-backlog-remove-article + (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) ;; Flush original article as well. (save-excursion @@ -2435,7 +2479,7 @@ groups." (set-window-start (get-buffer-window (current-buffer)) window-start) (goto-char p) (set-buffer buf))))) - + (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." (interactive) @@ -2445,7 +2489,7 @@ groups." (let ((case-fold-search nil)) (query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2")))) -;;; +;;; ;;; Article highlights ;;; @@ -2458,14 +2502,14 @@ groups." :group 'gnus-article-buttons :type 'regexp) -(defcustom gnus-button-alist - `(("\\(\\b<\\(url: ?\\)?news:\\([^>\n\t ]*\\)>\\)" 1 t - gnus-button-message-id 3) - ("\\bnews:\\([^\n\t ]+\\)" 0 t gnus-button-message-id 1) +(defcustom gnus-button-alist + `(("<\\(url: ?\\)?news:\\([^>\n\t ]*@[^>\n\t ]*\\)>" 0 t + gnus-button-message-id 2) + ("\\bnews:\\([^>\n\t ]*@[^>\n\t ]*+\\)" 0 t gnus-button-message-id 1) ("\\(\\b<\\(url: ?\\)?news:\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t gnus-button-fetch-group 4) ("\\bnews:\\(//\\)?\\([^>\n\t ]+\\)" 0 t gnus-button-fetch-group 2) - ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 + ("\\bin\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 2) @@ -2479,14 +2523,14 @@ Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where REGEXP: is the string matching text around the button, 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 -be added, +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. 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 regexp + :type '(repeat (list regexp (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -2494,11 +2538,11 @@ variable it the real callback function." :inline t (integer :tag "Regexp group"))))) -(defcustom gnus-header-button-alist +(defcustom gnus-header-button-alist `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>" 0 t gnus-button-message-id 0) ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) - ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" + ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 0 t gnus-button-mailto 0) ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) @@ -2516,7 +2560,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 + regexp (integer :tag "Button") (sexp :tag "Form") (function :tag "Callback") @@ -2592,7 +2636,7 @@ If N is negative, move backward instead." (defun gnus-article-highlight (&optional force) "Highlight current article. This function calls `gnus-article-highlight-headers', -`gnus-article-highlight-citation', +`gnus-article-highlight-citation', `gnus-article-highlight-signature', and `gnus-article-add-buttons' to do the highlighting. See the documentation for those functions." (interactive (list 'force)) @@ -2623,40 +2667,38 @@ do the highlighting. See the documentation for those functions." (case-fold-search t) (inhibit-point-motion-hooks t) entry regexp header-face field-face from hpoints fpoints) - (goto-char (point-min)) - (when (search-forward "\n\n" nil t) - (narrow-to-region (1- (point)) (point-min)) - (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))))))))) + (message-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)))))))) (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'." +`gnus-signature-separator' using `gnus-signature-face'." (interactive) (save-excursion (set-buffer gnus-article-buffer) @@ -2674,6 +2716,10 @@ It does this by highlighting everything after (gnus-article-add-button start (1- end) 'gnus-signature-toggle end))))))) +(defun gnus-button-in-region-p (b e prop) + "Say whether PROP exists in the region." + (text-property-not-all b e prop nil)) + (defun gnus-article-add-buttons (&optional force) "Find external references in the article and make buttons of them. \"External references\" are things like Message-IDs and URLs, as @@ -2681,16 +2727,22 @@ specified by `gnus-button-alist'." (interactive (list 'force)) (save-excursion (set-buffer gnus-article-buffer) - ;; Remove all old markers. - (while gnus-button-marker-list - (set-marker (pop gnus-button-marker-list) nil)) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (case-fold-search t) (alist gnus-button-alist) beg entry regexp) - (goto-char (point-min)) + ;; Remove all old markers. + (let (marker entry) + (while (setq marker (pop gnus-button-marker-list)) + (goto-char marker) + (when (setq entry (gnus-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'gnus-callback nil)) + (set-marker marker nil))) ;; We skip the headers. + (goto-char (point-min)) (unless (search-forward "\n\n" nil t) (goto-char (point-max))) (setq beg (point)) @@ -2703,11 +2755,12 @@ specified by `gnus-button-alist'." (from (match-beginning 0))) (when (and (or (eq t (nth 1 entry)) (eval (nth 1 entry))) - (not (get-text-property (point) 'gnus-callback))) + (not (gnus-button-in-region-p + start end 'gnus-callback))) ;; That optional form returned non-nil, so we add the - ;; button. - (gnus-article-add-button - start end 'gnus-button-push + ;; button. + (gnus-article-add-button + start end 'gnus-button-push (car (push (set-marker (make-marker) from) gnus-button-marker-list)))))))))) @@ -2743,7 +2796,7 @@ specified by `gnus-button-alist'." (form (nth 2 entry))) (goto-char (match-end 0)) (when (eval form) - (gnus-article-add-button + (gnus-article-add-button start end (nth 3 entry) (buffer-substring (match-beginning (nth 4 entry)) (match-end (nth 4 entry))))))) @@ -2757,7 +2810,7 @@ specified by `gnus-button-alist'." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face)) - (gnus-add-text-properties + (gnus-add-text-properties from to (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) @@ -2818,14 +2871,19 @@ specified by `gnus-button-alist'." (defun gnus-button-fetch-group (address) "Fetch GROUP specified by ADDRESS." - (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\(.*\\)$" address)) - (error "Can't parse %s" address) - (gnus-group-read-ephemeral-group - (match-string 4 address) - `(nntp ,(match-string 1 address) (nntp-address ,(match-string 1 address)) - (nntp-port-number ,(if (match-end 3) - (match-string 3 address) - "nntp")))))) + (if (not (string-match "[:/]" address)) + ;; This is just a simple group url. + (gnus-group-read-ephemeral-group address gnus-select-method) + (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$" + address)) + (error "Can't parse %s" address) + (gnus-group-read-ephemeral-group + (match-string 4 address) + `(nntp ,(match-string 1 address) + (nntp-address ,(match-string 1 address)) + (nntp-port-number ,(if (match-end 3) + (match-string 3 address) + "nntp"))))))) (defun gnus-split-string (string pattern) "Return a list of substrings of STRING which are separated by PATTERN." @@ -2834,7 +2892,7 @@ specified by `gnus-button-alist'." (setq parts (cons (substring string start (match-beginning 0)) parts) start (match-end 0))) (nreverse (cons (substring string start) parts)))) - + (defun gnus-url-parse-query-string (query &optional downcase) (let (retval pairs cur key val) (setq pairs (gnus-split-string query "&")) @@ -2852,14 +2910,14 @@ specified by `gnus-button-alist'." (setcdr cur (cons val (cdr cur))) (setq retval (cons (list key val) retval))))) retval)) - + (defun gnus-url-unhex (x) (if (> x ?9) (if (>= x ?a) (+ 10 (- x ?a)) (+ 10 (- x ?A))) (- x ?0))) - + (defun gnus-url-unhex-string (str &optional allow-newlines) "Remove %XXX embedded spaces, etc in a url. If optional second argument ALLOW-NEWLINES is non-nil, then allow the @@ -2873,7 +2931,7 @@ forbidden in URL encoding." (ch1 (gnus-url-unhex (elt str (+ start 1)))) (code (+ (* 16 ch1) (gnus-url-unhex (elt str (+ start 2)))))) - (setq tmp (concat + (setq tmp (concat tmp (substring str 0 start) (cond (allow-newlines @@ -2884,7 +2942,7 @@ forbidden in URL encoding." str (substring str (match-end 0))))) (setq tmp (concat tmp str)) tmp)) - + (defun gnus-url-mailto (url) ;; Send mail to someone (when (string-match "mailto:/*\\(.*\\)" url) @@ -2939,7 +2997,7 @@ forbidden in URL encoding." (defun gnus-insert-prev-page-button () (let ((buffer-read-only nil)) - (gnus-eval-format + (gnus-eval-format gnus-prev-page-line-format nil `(gnus-prev t local-map ,gnus-prev-page-map gnus-callback gnus-article-button-prev-page)))) @@ -2971,7 +3029,7 @@ forbidden in URL encoding." (let ((buffer-read-only nil)) (gnus-eval-format gnus-next-page-line-format nil `(gnus-next t local-map ,gnus-next-page-map - gnus-callback + gnus-callback gnus-article-button-next-page)))) (defun gnus-article-button-next-page (arg) @@ -2988,7 +3046,7 @@ forbidden in URL encoding." (let ((win (selected-window))) (select-window (get-buffer-window gnus-article-buffer t)) (gnus-article-prev-page) - (select-window win))) + (select-window win))) (gnus-ems-redefine)