Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cite.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents ac2d302a0011
children 1917ad0d78d7
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; gnus-cite.el --- parse citations in articles for Gnus 1 ;;; gnus-cite.el --- parse citations in articles for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk> 4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5 ;; Keywords: news, mail 5 ;; Keywords: news, mail
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'gnus) 28 (require 'gnus)
29 (require 'gnus-msg) 29 (require 'gnus-art)
30 (require 'gnus-ems) 30 (require 'gnus-range)
31 (eval-when-compile (require 'cl))
32
33 (eval-and-compile
34 (autoload 'gnus-article-add-button "gnus-vis"))
35 31
36 ;;; Customization: 32 ;;; Customization:
37 33
38 (defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n" 34 (defgroup gnus-cite nil
39 "Format of cited text buttons.") 35 "Citation."
40 36 :prefix "gnus-cite-"
41 (defvar gnus-cited-lines-visible nil 37 :link '(custom-manual "(gnus)Article Highlighting")
42 "The number of lines of hidden cited text to remain visible.") 38 :group 'gnus-article)
43 39
44 (defvar gnus-cite-parse-max-size 25000 40 (defcustom gnus-cite-reply-regexp
41 "^\\(Subject: Re\\|In-Reply-To\\|References\\):"
42 "If headers match this regexp it is reasonable to believe that
43 article has citations."
44 :group 'gnus-cite
45 :type 'string)
46
47 (defcustom gnus-cite-always-check nil
48 "Check article always for citations. Set it t to check all articles."
49 :group 'gnus-cite
50 :type '(choice (const :tag "no" nil)
51 (const :tag "yes" t)))
52
53 (defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
54 "Format of cited text buttons."
55 :group 'gnus-cite
56 :type 'string)
57
58 (defcustom gnus-cited-lines-visible nil
59 "The number of lines of hidden cited text to remain visible."
60 :group 'gnus-cite
61 :type '(choice (const :tag "none" nil)
62 integer))
63
64 (defcustom gnus-cite-parse-max-size 25000
45 "Maximum article size (in bytes) where parsing citations is allowed. 65 "Maximum article size (in bytes) where parsing citations is allowed.
46 Set it to nil to parse all articles.") 66 Set it to nil to parse all articles."
47 67 :group 'gnus-cite
48 (defvar gnus-cite-prefix-regexp 68 :type '(choice (const :tag "all" nil)
69 integer))
70
71 (defcustom gnus-cite-prefix-regexp
49 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" 72 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
50 "Regexp matching the longest possible citation prefix on a line.") 73 "Regexp matching the longest possible citation prefix on a line."
51 74 :group 'gnus-cite
52 (defvar gnus-cite-max-prefix 20 75 :type 'regexp)
53 "Maximum possible length for a citation prefix.") 76
54 77 (defcustom gnus-cite-max-prefix 20
55 (defvar gnus-supercite-regexp 78 "Maximum possible length for a citation prefix."
79 :group 'gnus-cite
80 :type 'integer)
81
82 (defcustom gnus-supercite-regexp
56 (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" 83 (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
57 ">>>>> +\"\\([^\"\n]+\\)\" +==") 84 ">>>>> +\"\\([^\"\n]+\\)\" +==")
58 "Regexp matching normal Supercite attribution lines. 85 "Regexp matching normal Supercite attribution lines.
59 The first grouping must match prefixes added by other packages.") 86 The first grouping must match prefixes added by other packages."
60 87 :group 'gnus-cite
61 (defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" 88 :type 'regexp)
89
90 (defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
62 "Regexp matching mangled Supercite attribution lines. 91 "Regexp matching mangled Supercite attribution lines.
63 The first regexp group should match the Supercite attribution.") 92 The first regexp group should match the Supercite attribution."
64 93 :group 'gnus-cite
65 (defvar gnus-cite-minimum-match-count 2 94 :type 'regexp)
66 "Minimum number of identical prefixes before we believe it's a citation.") 95
67 96 (defcustom gnus-cite-minimum-match-count 2
68 ;see gnus-cus.el 97 "Minimum number of identical prefixes before we believe it's a citation."
69 ;(defvar gnus-cite-face-list 98 :group 'gnus-cite
70 ; (if (eq gnus-display-type 'color) 99 :type 'integer)
71 ; (if (eq gnus-background-mode 'dark) 'light 'dark) 100
72 ; '(italic)) 101 (defcustom gnus-cite-attribution-prefix "in article\\|in <"
73 ; "Faces used for displaying different citations. 102 "Regexp matching the beginning of an attribution line."
74 ;It is either a list of face names, or one of the following special 103 :group 'gnus-cite
75 ;values: 104 :type 'regexp)
76 105
77 ;dark: Create faces from `gnus-face-dark-name-list'. 106 (defcustom gnus-cite-attribution-suffix
78 ;light: Create faces from `gnus-face-light-name-list'.
79
80 ;The variable `gnus-make-foreground' determines whether the created
81 ;faces change the foreground or the background colors.")
82
83 (defvar gnus-cite-attribution-prefix "in article\\|in <"
84 "Regexp matching the beginning of an attribution line.")
85
86 (defvar gnus-cite-attribution-suffix
87 "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$" 107 "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
88 "Regexp matching the end of an attribution line. 108 "Regexp matching the end of an attribution line.
89 The text matching the first grouping will be used as a button.") 109 The text matching the first grouping will be used as a button."
90 110 :group 'gnus-cite
91 ;see gnus-cus.el 111 :type 'regexp)
92 ;(defvar gnus-cite-attribution-face 'underline 112
93 ; "Face used for attribution lines. 113 (defface gnus-cite-attribution-face '((t
94 ;It is merged with the face for the cited text belonging to the attribution.") 114 (:underline t)))
95 115 "Face used for attribution lines.")
96 ;see gnus-cus.el 116
97 ;(defvar gnus-cite-hide-percentage 50 117 (defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
98 ; "Only hide cited text if it is larger than this percent of the body.") 118 "Face used for attribution lines.
99 119 It is merged with the face for the cited text belonging to the attribution."
100 ;see gnus-cus.el 120 :group 'gnus-cite
101 ;(defvar gnus-cite-hide-absolute 10 121 :type 'face)
102 ; "Only hide cited text if there is at least this number of cited lines.") 122
103 123 (defface gnus-cite-face-1 '((((class color)
104 ;see gnus-cus.el 124 (background dark))
105 ;(defvar gnus-face-light-name-list 125 (:foreground "light blue"))
106 ; '("light blue" "light cyan" "light yellow" "light pink" 126 (((class color)
107 ; "pale green" "beige" "orange" "magenta" "violet" "medium purple" 127 (background light))
108 ; "turquoise") 128 (:foreground "MidnightBlue"))
109 ; "Names of light colors.") 129 (t
110 130 (:italic t)))
111 ;see gnus-cus.el 131 "Citation face.")
112 ;(defvar gnus-face-dark-name-list 132
113 ; '("dark salmon" "firebrick" 133 (defface gnus-cite-face-2 '((((class color)
114 ; "dark green" "dark orange" "dark khaki" "dark violet" 134 (background dark))
115 ; "dark turquoise") 135 (:foreground "light cyan"))
116 ; "Names of dark colors.") 136 (((class color)
137 (background light))
138 (:foreground "firebrick"))
139 (t
140 (:italic t)))
141 "Citation face.")
142
143 (defface gnus-cite-face-3 '((((class color)
144 (background dark))
145 (:foreground "light yellow"))
146 (((class color)
147 (background light))
148 (:foreground "dark green"))
149 (t
150 (:italic t)))
151 "Citation face.")
152
153 (defface gnus-cite-face-4 '((((class color)
154 (background dark))
155 (:foreground "light pink"))
156 (((class color)
157 (background light))
158 (:foreground "OrangeRed"))
159 (t
160 (:italic t)))
161 "Citation face.")
162
163 (defface gnus-cite-face-5 '((((class color)
164 (background dark))
165 (:foreground "pale green"))
166 (((class color)
167 (background light))
168 (:foreground "dark khaki"))
169 (t
170 (:italic t)))
171 "Citation face.")
172
173 (defface gnus-cite-face-6 '((((class color)
174 (background dark))
175 (:foreground "beige"))
176 (((class color)
177 (background light))
178 (:foreground "dark violet"))
179 (t
180 (:italic t)))
181 "Citation face.")
182
183 (defface gnus-cite-face-7 '((((class color)
184 (background dark))
185 (:foreground "orange"))
186 (((class color)
187 (background light))
188 (:foreground "SteelBlue4"))
189 (t
190 (:italic t)))
191 "Citation face.")
192
193 (defface gnus-cite-face-8 '((((class color)
194 (background dark))
195 (:foreground "magenta"))
196 (((class color)
197 (background light))
198 (:foreground "magenta"))
199 (t
200 (:italic t)))
201 "Citation face.")
202
203 (defface gnus-cite-face-9 '((((class color)
204 (background dark))
205 (:foreground "violet"))
206 (((class color)
207 (background light))
208 (:foreground "violet"))
209 (t
210 (:italic t)))
211 "Citation face.")
212
213 (defface gnus-cite-face-10 '((((class color)
214 (background dark))
215 (:foreground "medium purple"))
216 (((class color)
217 (background light))
218 (:foreground "medium purple"))
219 (t
220 (:italic t)))
221 "Citation face.")
222
223 (defface gnus-cite-face-11 '((((class color)
224 (background dark))
225 (:foreground "turquoise"))
226 (((class color)
227 (background light))
228 (:foreground "turquoise"))
229 (t
230 (:italic t)))
231 "Citation face.")
232
233 (defcustom gnus-cite-face-list
234 '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4
235 gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
236 gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
237 "List of faces used for highlighting citations.
238
239 When there are citations from multiple articles in the same message,
240 Gnus will try to give each citation from each article its own face.
241 This should make it easier to see who wrote what."
242 :group 'gnus-cite
243 :type '(repeat face))
244
245 (defcustom gnus-cite-hide-percentage 50
246 "Only hide excess citation if above this percentage of the body."
247 :group 'gnus-cite
248 :type 'number)
249
250 (defcustom gnus-cite-hide-absolute 10
251 "Only hide excess citation if above this number of lines in the body."
252 :group 'gnus-cite
253 :type 'integer)
117 254
118 ;;; Internal Variables: 255 ;;; Internal Variables:
119 256
120 (defvar gnus-cite-article nil) 257 (defvar gnus-cite-article nil)
121 258
139 ;; IN: is the line number of the previous line if part of the same attribution, 276 ;; IN: is the line number of the previous line if part of the same attribution,
140 ;; PREFIX: Is the citation prefix of the attribution line(s), and 277 ;; PREFIX: Is the citation prefix of the attribution line(s), and
141 ;; TAG: Is a Supercite tag, if any. 278 ;; TAG: Is a Supercite tag, if any.
142 279
143 (defvar gnus-cited-text-button-line-format-alist 280 (defvar gnus-cited-text-button-line-format-alist
144 `((?b beg ?d) 281 `((?b (marker-position beg) ?d)
145 (?e end ?d) 282 (?e (marker-position end) ?d)
146 (?l (- end beg) ?d))) 283 (?l (- end beg) ?d)))
147 (defvar gnus-cited-text-button-line-format-spec nil) 284 (defvar gnus-cited-text-button-line-format-spec nil)
148 285
149 ;;; Commands: 286 ;;; Commands:
150 287
159 lines matches `gnus-cite-prefix-regexp' with the same prefix. 296 lines matches `gnus-cite-prefix-regexp' with the same prefix.
160 297
161 Lines matching `gnus-cite-attribution-suffix' and perhaps 298 Lines matching `gnus-cite-attribution-suffix' and perhaps
162 `gnus-cite-attribution-prefix' are considered attribution lines." 299 `gnus-cite-attribution-prefix' are considered attribution lines."
163 (interactive (list 'force)) 300 (interactive (list 'force))
164 ;; Create dark or light faces if necessary.
165 (cond ((eq gnus-cite-face-list 'light)
166 (setq gnus-cite-face-list
167 (mapcar 'gnus-make-face gnus-face-light-name-list)))
168 ((eq gnus-cite-face-list 'dark)
169 (setq gnus-cite-face-list
170 (mapcar 'gnus-make-face gnus-face-dark-name-list))))
171 (save-excursion 301 (save-excursion
172 (set-buffer gnus-article-buffer) 302 (set-buffer gnus-article-buffer)
173 (gnus-cite-parse-maybe force) 303 (gnus-cite-parse-maybe force)
174 (let ((buffer-read-only nil) 304 (let ((buffer-read-only nil)
175 (alist gnus-cite-prefix-alist) 305 (alist gnus-cite-prefix-alist)
200 prefix (cdr entry) 330 prefix (cdr entry)
201 skip (gnus-cite-find-prefix number) 331 skip (gnus-cite-find-prefix number)
202 face (cdr (assoc prefix face-alist))) 332 face (cdr (assoc prefix face-alist)))
203 ;; Add attribution button. 333 ;; Add attribution button.
204 (goto-line number) 334 (goto-line number)
205 (if (re-search-forward gnus-cite-attribution-suffix 335 (when (re-search-forward gnus-cite-attribution-suffix
206 (save-excursion (end-of-line 1) (point)) 336 (save-excursion (end-of-line 1) (point))
207 t) 337 t)
208 (gnus-article-add-button (match-beginning 1) (match-end 1) 338 (gnus-article-add-button (match-beginning 1) (match-end 1)
209 'gnus-cite-toggle prefix)) 339 'gnus-cite-toggle prefix))
210 ;; Highlight attribution line. 340 ;; Highlight attribution line.
211 (gnus-cite-add-face number skip face) 341 (gnus-cite-add-face number skip face)
212 (gnus-cite-add-face number skip gnus-cite-attribution-face)) 342 (gnus-cite-add-face number skip gnus-cite-attribution-face))
213 ;; Loop through attribution lines. 343 ;; Loop through attribution lines.
214 (setq alist gnus-cite-loose-attribution-alist) 344 (setq alist gnus-cite-loose-attribution-alist)
239 (= (1- number) (car numbers))) 369 (= (1- number) (car numbers)))
240 (setq number (pop numbers))) 370 (setq number (pop numbers)))
241 (goto-char (point-min)) 371 (goto-char (point-min))
242 (forward-line (1- number)) 372 (forward-line (1- number))
243 (push (cons (point-marker) prefix) marks))) 373 (push (cons (point-marker) prefix) marks)))
374 ;; Skip to the beginning of the body.
244 (goto-char (point-min)) 375 (goto-char (point-min))
245 (search-forward "\n\n" nil t) 376 (search-forward "\n\n" nil t)
246 (push (cons (point-marker) "") marks) 377 (push (cons (point-marker) "") marks)
378 ;; Find the end of the body.
247 (goto-char (point-max)) 379 (goto-char (point-max))
248 (re-search-backward gnus-signature-separator nil t) 380 (gnus-article-search-signature)
249 (push (cons (point-marker) "") marks) 381 (push (cons (point-marker) "") marks)
382 ;; Sort the marks.
250 (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) 383 (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
251 (let* ((omarks marks)) 384 (let ((omarks marks))
252 (setq marks nil) 385 (setq marks nil)
253 (while (cdr omarks) 386 (while (cdr omarks)
254 (if (= (caar omarks) (caadr omarks)) 387 (if (= (caar omarks) (caadr omarks))
255 (progn 388 (progn
256 (unless (equal (cdar omarks) "") 389 (unless (equal (cdar omarks) "")
257 (push (car omarks) marks)) 390 (push (car omarks) marks))
258 (unless (equal (cdadr omarks) "") 391 (unless (equal (cdadr omarks) "")
259 (push (cadr omarks) marks)) 392 (push (cadr omarks) marks))
260 (setq omarks (cdr omarks))) 393 (unless (and (equal (cdar omarks) "")
394 (equal (cdadr omarks) "")
395 (not (cddr omarks)))
396 (setq omarks (cdr omarks))))
261 (push (car omarks) marks)) 397 (push (car omarks) marks))
262 (setq omarks (cdr omarks))) 398 (setq omarks (cdr omarks)))
263 (when (car omarks) 399 (when (car omarks)
264 (push (car omarks) marks)) 400 (push (car omarks) marks))
265 (setq marks (setq m (nreverse marks))) 401 (setq marks (setq m (nreverse marks)))
270 (forward-line 1) 406 (forward-line 1)
271 (= (point) (caaddr m))) 407 (= (point) (caaddr m)))
272 (setcdr m (cdddr m)) 408 (setcdr m (cdddr m))
273 (setq m (cdr m)))) 409 (setq m (cdr m))))
274 marks)))) 410 marks))))
275 411
276 412 (defun gnus-article-fill-cited-article (&optional force width)
277 (defun gnus-article-fill-cited-article (&optional force) 413 "Do word wrapping in the current article.
278 "Do word wrapping in the current article." 414 If WIDTH (the numerical prefix), use that text width when filling."
279 (interactive (list t)) 415 (interactive (list t current-prefix-arg))
280 (save-excursion 416 (save-excursion
281 (set-buffer gnus-article-buffer) 417 (set-buffer gnus-article-buffer)
282 (let ((buffer-read-only nil) 418 (let ((buffer-read-only nil)
283 (inhibit-point-motion-hooks t) 419 (inhibit-point-motion-hooks t)
284 (marks (gnus-dissect-cited-text)) 420 (marks (gnus-dissect-cited-text))
285 (adaptive-fill-mode nil)) 421 (adaptive-fill-mode nil)
422 (fill-column (if width (prefix-numeric-value width) fill-column)))
286 (save-restriction 423 (save-restriction
287 (while (cdr marks) 424 (while (cdr marks)
288 (widen) 425 (widen)
289 (narrow-to-region (caar marks) (caadr marks)) 426 (narrow-to-region (caar marks) (caadr marks))
290 (let ((adaptive-fill-regexp 427 (let ((adaptive-fill-regexp
292 (fill-prefix (cdar marks))) 429 (fill-prefix (cdar marks)))
293 (fill-region (point-min) (point-max))) 430 (fill-region (point-min) (point-max)))
294 (set-marker (caar marks) nil) 431 (set-marker (caar marks) nil)
295 (setq marks (cdr marks))) 432 (setq marks (cdr marks)))
296 (when marks 433 (when marks
297 (set-marker (caar marks) nil)))))) 434 (set-marker (caar marks) nil))
435 ;; All this information is now incorrect.
436 (setq gnus-cite-prefix-alist nil
437 gnus-cite-attribution-alist nil
438 gnus-cite-loose-prefix-alist nil
439 gnus-cite-loose-attribution-alist nil)))))
298 440
299 (defun gnus-article-hide-citation (&optional arg force) 441 (defun gnus-article-hide-citation (&optional arg force)
300 "Toggle hiding of all cited text except attribution lines. 442 "Toggle hiding of all cited text except attribution lines.
301 See the documentation for `gnus-article-highlight-citation'. 443 See the documentation for `gnus-article-highlight-citation'.
302 If given a negative prefix, always show; if given a positive prefix, 444 If given a negative prefix, always show; if given a positive prefix,
303 always hide." 445 always hide."
304 (interactive (append (gnus-hidden-arg) (list 'force))) 446 (interactive (append (gnus-article-hidden-arg) (list 'force)))
305 (setq gnus-cited-text-button-line-format-spec 447 (setq gnus-cited-text-button-line-format-spec
306 (gnus-parse-format gnus-cited-text-button-line-format 448 (gnus-parse-format gnus-cited-text-button-line-format
307 gnus-cited-text-button-line-format-alist t)) 449 gnus-cited-text-button-line-format-alist t))
308 (unless (gnus-article-check-hidden-text 'cite arg) 450 (save-excursion
309 (save-excursion 451 (set-buffer gnus-article-buffer)
310 (set-buffer gnus-article-buffer) 452 (cond
453 ((gnus-article-check-hidden-text 'cite arg)
454 t)
455 ((gnus-article-text-type-exists-p 'cite)
456 (let ((buffer-read-only nil))
457 (gnus-article-hide-text-of-type 'cite)))
458 (t
311 (let ((buffer-read-only nil) 459 (let ((buffer-read-only nil)
312 (marks (gnus-dissect-cited-text)) 460 (marks (gnus-dissect-cited-text))
313 (inhibit-point-motion-hooks t) 461 (inhibit-point-motion-hooks t)
314 (props (nconc (list 'gnus-type 'cite) 462 (props (nconc (list 'article-type 'cite)
315 gnus-hidden-properties)) 463 gnus-hidden-properties))
316 beg end) 464 beg end)
317 (while marks 465 (while marks
318 (setq beg nil 466 (setq beg nil
319 end nil) 467 end nil)
335 (when (and beg end) 483 (when (and beg end)
336 (gnus-add-text-properties beg end props) 484 (gnus-add-text-properties beg end props)
337 (goto-char beg) 485 (goto-char beg)
338 (unless (save-excursion (search-backward "\n\n" nil t)) 486 (unless (save-excursion (search-backward "\n\n" nil t))
339 (insert "\n")) 487 (insert "\n"))
340 (gnus-article-add-button 488 (put-text-property
341 (point) 489 (point)
342 (progn (eval gnus-cited-text-button-line-format-spec) (point)) 490 (progn
343 `gnus-article-toggle-cited-text (cons beg end)) 491 (gnus-article-add-button
344 (set-marker beg (point)))))))) 492 (point)
493 (progn (eval gnus-cited-text-button-line-format-spec) (point))
494 `gnus-article-toggle-cited-text (cons beg end))
495 (point))
496 'article-type 'annotation)
497 (set-marker beg (point)))))))))
345 498
346 (defun gnus-article-toggle-cited-text (region) 499 (defun gnus-article-toggle-cited-text (region)
347 "Toggle hiding the text in REGION." 500 "Toggle hiding the text in REGION."
348 (let (buffer-read-only) 501 (let (buffer-read-only)
349 (funcall 502 (funcall
360 This will do nothing unless at least `gnus-cite-hide-percentage' 513 This will do nothing unless at least `gnus-cite-hide-percentage'
361 percent and at least `gnus-cite-hide-absolute' lines of the body is 514 percent and at least `gnus-cite-hide-absolute' lines of the body is
362 cited text with attributions. When called interactively, these two 515 cited text with attributions. When called interactively, these two
363 variables are ignored. 516 variables are ignored.
364 See also the documentation for `gnus-article-highlight-citation'." 517 See also the documentation for `gnus-article-highlight-citation'."
365 (interactive (append (gnus-hidden-arg) (list 'force))) 518 (interactive (append (gnus-article-hidden-arg) (list 'force)))
366 (unless (gnus-article-check-hidden-text 'cite arg) 519 (unless (gnus-article-check-hidden-text 'cite arg)
367 (save-excursion 520 (save-excursion
368 (set-buffer gnus-article-buffer) 521 (set-buffer gnus-article-buffer)
369 (gnus-cite-parse-maybe force) 522 (gnus-cite-parse-maybe force)
370 (goto-char (point-min)) 523 (goto-char (point-min))
374 (buffer-read-only nil) 527 (buffer-read-only nil)
375 (inhibit-point-motion-hooks t) 528 (inhibit-point-motion-hooks t)
376 (hiden 0) 529 (hiden 0)
377 total) 530 total)
378 (goto-char (point-max)) 531 (goto-char (point-max))
379 (re-search-backward gnus-signature-separator nil t) 532 (gnus-article-search-signature)
380 (setq total (count-lines start (point))) 533 (setq total (count-lines start (point)))
381 (while atts 534 (while atts
382 (setq hiden (+ hiden (length (cdr (assoc (cdar atts) 535 (setq hiden (+ hiden (length (cdr (assoc (cdar atts)
383 gnus-cite-prefix-alist)))) 536 gnus-cite-prefix-alist))))
384 atts (cdr atts))) 537 atts (cdr atts)))
385 (if (or force 538 (when (or force
386 (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) 539 (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
387 (> hiden gnus-cite-hide-absolute))) 540 (> hiden gnus-cite-hide-absolute)))
388 (progn 541 (setq atts gnus-cite-attribution-alist)
389 (setq atts gnus-cite-attribution-alist) 542 (while atts
390 (while atts 543 (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
391 (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) 544 atts (cdr atts))
392 atts (cdr atts)) 545 (while total
393 (while total 546 (setq hiden (car total)
394 (setq hiden (car total) 547 total (cdr total))
395 total (cdr total)) 548 (goto-line hiden)
396 (goto-line hiden) 549 (unless (assq hiden gnus-cite-attribution-alist)
397 (or (assq hiden gnus-cite-attribution-alist) 550 (gnus-add-text-properties
398 (gnus-add-text-properties 551 (point) (progn (forward-line 1) (point))
399 (point) (progn (forward-line 1) (point)) 552 (nconc (list 'article-type 'cite)
400 (nconc (list 'gnus-type 'cite) 553 gnus-hidden-properties))))))))))
401 gnus-hidden-properties)))))))))))
402 554
403 (defun gnus-article-hide-citation-in-followups () 555 (defun gnus-article-hide-citation-in-followups ()
404 "Hide cited text in non-root articles." 556 "Hide cited text in non-root articles."
405 (interactive) 557 (interactive)
406 (save-excursion 558 (save-excursion
421 (setq gnus-cite-prefix-alist nil 573 (setq gnus-cite-prefix-alist nil
422 gnus-cite-attribution-alist nil 574 gnus-cite-attribution-alist nil
423 gnus-cite-loose-prefix-alist nil 575 gnus-cite-loose-prefix-alist nil
424 gnus-cite-loose-attribution-alist nil) 576 gnus-cite-loose-attribution-alist nil)
425 ;; Parse if not too large. 577 ;; Parse if not too large.
426 (if (and (not force) 578 (if (and (not force)
427 gnus-cite-parse-max-size 579 gnus-cite-parse-max-size
428 (> (buffer-size) gnus-cite-parse-max-size)) 580 (> (buffer-size) gnus-cite-parse-max-size))
429 () 581 ()
430 (setq gnus-cite-article (cons (car gnus-article-current) 582 (setq gnus-cite-article (cons (car gnus-article-current)
431 (cdr gnus-article-current))) 583 (cdr gnus-article-current)))
432 (gnus-cite-parse)))) 584 (gnus-cite-parse-wrapper))))
585
586 (defun gnus-cite-parse-wrapper ()
587 ;; Wrap chopped gnus-cite-parse
588 (goto-char (point-min))
589 (unless (search-forward "\n\n" nil t)
590 (goto-char (point-max)))
591 (save-excursion
592 (gnus-cite-parse-attributions))
593 ;; Try to avoid check citation if there is no reason to believe
594 ;; that article has citations
595 (if (or gnus-cite-always-check
596 (save-excursion
597 (re-search-backward gnus-cite-reply-regexp nil t))
598 gnus-cite-loose-attribution-alist)
599 (progn (save-excursion
600 (gnus-cite-parse))
601 (save-excursion
602 (gnus-cite-connect-attributions)))))
433 603
434 (defun gnus-cite-parse () 604 (defun gnus-cite-parse ()
435 ;; Parse and connect citation prefixes and attribution lines. 605 ;; Parse and connect citation prefixes and attribution lines.
436 606
437 ;; Parse current buffer searching for citation prefixes. 607 ;; Parse current buffer searching for citation prefixes.
438 (goto-char (point-min))
439 (or (search-forward "\n\n" nil t)
440 (goto-char (point-max)))
441 (let ((line (1+ (count-lines (point-min) (point)))) 608 (let ((line (1+ (count-lines (point-min) (point))))
442 (case-fold-search t) 609 (case-fold-search t)
443 (max (save-excursion 610 (max (save-excursion
444 (goto-char (point-max)) 611 (goto-char (point-max))
445 (re-search-backward gnus-signature-separator nil t) 612 (gnus-article-search-signature)
446 (point))) 613 (point)))
447 alist entry start begin end numbers prefix) 614 alist entry start begin end numbers prefix)
448 ;; Get all potential prefixes in `alist'. 615 ;; Get all potential prefixes in `alist'.
449 (while (< (point) max) 616 (while (< (point) max)
450 ;; Each line. 617 ;; Each line.
451 (setq begin (point) 618 (setq begin (point)
452 end (progn (beginning-of-line 2) (point)) 619 end (progn (beginning-of-line 2) (point))
453 start end) 620 start end)
454 (goto-char begin) 621 (goto-char begin)
455 ;; Ignore standard Supercite attribution prefix. 622 ;; Ignore standard Supercite attribution prefix.
456 (if (looking-at gnus-supercite-regexp) 623 (when (looking-at gnus-supercite-regexp)
457 (if (match-end 1) 624 (if (match-end 1)
458 (setq end (1+ (match-end 1))) 625 (setq end (1+ (match-end 1)))
459 (setq end (1+ begin)))) 626 (setq end (1+ begin))))
460 ;; Ignore very long prefixes. 627 ;; Ignore very long prefixes.
461 (if (> end (+ (point) gnus-cite-max-prefix)) 628 (when (> end (+ (point) gnus-cite-max-prefix))
462 (setq end (+ (point) gnus-cite-max-prefix))) 629 (setq end (+ (point) gnus-cite-max-prefix)))
463 (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) 630 (while (re-search-forward gnus-cite-prefix-regexp (1- end) t)
464 ;; Each prefix. 631 ;; Each prefix.
465 (setq end (match-end 0) 632 (setq end (match-end 0)
466 prefix (buffer-substring begin end)) 633 prefix (buffer-substring begin end))
467 (gnus-set-text-properties 0 (length prefix) nil prefix) 634 (gnus-set-text-properties 0 (length prefix) nil prefix)
468 (setq entry (assoc prefix alist)) 635 (setq entry (assoc prefix alist))
469 (if entry 636 (if entry
470 (setcdr entry (cons line (cdr entry))) 637 (setcdr entry (cons line (cdr entry)))
471 (setq alist (cons (list prefix line) alist))) 638 (push (list prefix line) alist))
472 (goto-char begin)) 639 (goto-char begin))
473 (goto-char start) 640 (goto-char start)
474 (setq line (1+ line))) 641 (setq line (1+ line)))
475 ;; We got all the potential prefixes. Now create 642 ;; We got all the potential prefixes. Now create
476 ;; `gnus-cite-prefix-alist' containing the oldest prefix for each 643 ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
477 ;; line that appears at least gnus-cite-minimum-match-count 644 ;; line that appears at least gnus-cite-minimum-match-count
478 ;; times. First sort them by length. Longer is older. 645 ;; times. First sort them by length. Longer is older.
479 (setq alist (sort alist (lambda (a b) 646 (setq alist (sort alist (lambda (a b)
480 (> (length (car a)) (length (car b)))))) 647 (> (length (car a)) (length (car b))))))
481 (while alist 648 (while alist
482 (setq entry (car alist) 649 (setq entry (car alist)
483 prefix (car entry) 650 prefix (car entry)
490 ((< (length numbers) gnus-cite-minimum-match-count) 657 ((< (length numbers) gnus-cite-minimum-match-count)
491 ;; Too few lines with this prefix. We keep it a bit 658 ;; Too few lines with this prefix. We keep it a bit
492 ;; longer in case it is an exact match for an attribution 659 ;; longer in case it is an exact match for an attribution
493 ;; line, but we don't remove the line from other 660 ;; line, but we don't remove the line from other
494 ;; prefixes. 661 ;; prefixes.
495 (setq gnus-cite-prefix-alist 662 (push entry gnus-cite-prefix-alist))
496 (cons entry gnus-cite-prefix-alist)))
497 (t 663 (t
498 (setq gnus-cite-prefix-alist (cons entry 664 (push entry
499 gnus-cite-prefix-alist)) 665 gnus-cite-prefix-alist)
500 ;; Remove articles from other prefixes. 666 ;; Remove articles from other prefixes.
501 (let ((loop alist) 667 (let ((loop alist)
502 current) 668 current)
503 (while loop 669 (while loop
504 (setq current (car loop) 670 (setq current (car loop)
505 loop (cdr loop)) 671 loop (cdr loop))
506 (setcdr current 672 (setcdr current
507 (gnus-set-difference (cdr current) numbers)))))))) 673 (gnus-set-difference (cdr current) numbers)))))))))
674
675 (defun gnus-cite-parse-attributions ()
676 (let (al-alist)
677 ;; Parse attributions
678 (while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
679 (let* ((start (match-beginning 0))
680 (end (match-end 0))
681 (wrote (count-lines (point-min) end))
682 (prefix (gnus-cite-find-prefix wrote))
683 ;; Check previous line for an attribution leader.
684 (tag (progn
685 (beginning-of-line 1)
686 (when (looking-at gnus-supercite-secondary-regexp)
687 (buffer-substring (match-beginning 1)
688 (match-end 1)))))
689 (in (progn
690 (goto-char start)
691 (and (re-search-backward gnus-cite-attribution-prefix
692 (save-excursion
693 (beginning-of-line 0)
694 (point))
695 t)
696 (not (re-search-forward gnus-cite-attribution-suffix
697 start t))
698 (count-lines (point-min) (1+ (point)))))))
699 (when (eq wrote in)
700 (setq in nil))
701 (goto-char end)
702 ;; don't add duplicates
703 (let ((al (buffer-substring (save-excursion (beginning-of-line 0)
704 (1+ (point)))
705 end)))
706 (if (not (assoc al al-alist))
707 (progn
708 (push (list wrote in prefix tag)
709 gnus-cite-loose-attribution-alist)
710 (push (cons al t) al-alist))))))))
711
712 (defun gnus-cite-connect-attributions ()
713 ;; Connect attributions to citations
714
508 ;; No citations have been connected to attribution lines yet. 715 ;; No citations have been connected to attribution lines yet.
509 (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) 716 (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil))
510 717
511 ;; Parse current buffer searching for attribution lines. 718 ;; Parse current buffer searching for attribution lines.
512 (goto-char (point-min))
513 (search-forward "\n\n" nil t)
514 (while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
515 (let* ((start (match-beginning 0))
516 (end (match-end 0))
517 (wrote (count-lines (point-min) end))
518 (prefix (gnus-cite-find-prefix wrote))
519 ;; Check previous line for an attribution leader.
520 (tag (progn
521 (beginning-of-line 1)
522 (and (looking-at gnus-supercite-secondary-regexp)
523 (buffer-substring (match-beginning 1)
524 (match-end 1)))))
525 (in (progn
526 (goto-char start)
527 (and (re-search-backward gnus-cite-attribution-prefix
528 (save-excursion
529 (beginning-of-line 0)
530 (point))
531 t)
532 (not (re-search-forward gnus-cite-attribution-suffix
533 start t))
534 (count-lines (point-min) (1+ (point)))))))
535 (if (eq wrote in)
536 (setq in nil))
537 (goto-char end)
538 (setq gnus-cite-loose-attribution-alist
539 (cons (list wrote in prefix tag)
540 gnus-cite-loose-attribution-alist))))
541 ;; Find exact supercite citations. 719 ;; Find exact supercite citations.
542 (gnus-cite-match-attributions 'small nil 720 (gnus-cite-match-attributions 'small nil
543 (lambda (prefix tag) 721 (lambda (prefix tag)
544 (if tag 722 (when tag
545 (concat "\\`" 723 (concat "\\`"
546 (regexp-quote prefix) "[ \t]*" 724 (regexp-quote prefix) "[ \t]*"
547 (regexp-quote tag) ">")))) 725 (regexp-quote tag) ">"))))
548 ;; Find loose supercite citations after attributions. 726 ;; Find loose supercite citations after attributions.
549 (gnus-cite-match-attributions 'small t 727 (gnus-cite-match-attributions 'small t
550 (lambda (prefix tag) 728 (lambda (prefix tag)
551 (if tag (concat "\\<" 729 (when tag
552 (regexp-quote tag) 730 (concat "\\<"
553 "\\>")))) 731 (regexp-quote tag)
732 "\\>"))))
554 ;; Find loose supercite citations anywhere. 733 ;; Find loose supercite citations anywhere.
555 (gnus-cite-match-attributions 'small nil 734 (gnus-cite-match-attributions 'small nil
556 (lambda (prefix tag) 735 (lambda (prefix tag)
557 (if tag (concat "\\<" 736 (when tag
558 (regexp-quote tag) 737 (concat "\\<"
559 "\\>")))) 738 (regexp-quote tag)
739 "\\>"))))
560 ;; Find nested citations after attributions. 740 ;; Find nested citations after attributions.
561 (gnus-cite-match-attributions 'small-if-unique t 741 (gnus-cite-match-attributions 'small-if-unique t
562 (lambda (prefix tag) 742 (lambda (prefix tag)
563 (concat "\\`" (regexp-quote prefix) ".+"))) 743 (concat "\\`" (regexp-quote prefix) ".+")))
564 ;; Find nested citations anywhere. 744 ;; Find nested citations anywhere.
569 (let ((alist gnus-cite-loose-prefix-alist) 749 (let ((alist gnus-cite-loose-prefix-alist)
570 entry) 750 entry)
571 (while alist 751 (while alist
572 (setq entry (car alist) 752 (setq entry (car alist)
573 alist (cdr alist)) 753 alist (cdr alist))
574 (if (< (length (cdr entry)) gnus-cite-minimum-match-count) 754 (when (< (length (cdr entry)) gnus-cite-minimum-match-count)
575 (setq gnus-cite-prefix-alist 755 (setq gnus-cite-prefix-alist
576 (delq entry gnus-cite-prefix-alist) 756 (delq entry gnus-cite-prefix-alist)
577 gnus-cite-loose-prefix-alist 757 gnus-cite-loose-prefix-alist
578 (delq entry gnus-cite-loose-prefix-alist))))) 758 (delq entry gnus-cite-loose-prefix-alist)))))
579 ;; Find flat attributions. 759 ;; Find flat attributions.
580 (gnus-cite-match-attributions 'first t nil) 760 (gnus-cite-match-attributions 'first t nil)
581 ;; Find any attributions (are we getting desperate yet?). 761 ;; Find any attributions (are we getting desperate yet?).
582 (gnus-cite-match-attributions 'first nil nil)) 762 (gnus-cite-match-attributions 'first nil nil))
583 763
635 smallest compare)))) 815 smallest compare))))
636 (if (null best) 816 (if (null best)
637 () 817 ()
638 (setq gnus-cite-loose-attribution-alist 818 (setq gnus-cite-loose-attribution-alist
639 (delq att gnus-cite-loose-attribution-alist)) 819 (delq att gnus-cite-loose-attribution-alist))
640 (setq gnus-cite-attribution-alist 820 (push (cons wrote (car best)) gnus-cite-attribution-alist)
641 (cons (cons wrote (car best)) gnus-cite-attribution-alist)) 821 (when in
642 (if in 822 (push (cons in (car best)) gnus-cite-attribution-alist))
643 (setq gnus-cite-attribution-alist 823 (when (memq best gnus-cite-loose-prefix-alist)
644 (cons (cons in (car best)) gnus-cite-attribution-alist))) 824 (let ((loop gnus-cite-prefix-alist)
645 (if (memq best gnus-cite-loose-prefix-alist) 825 (numbers (cdr best))
646 (let ((loop gnus-cite-prefix-alist) 826 current)
647 (numbers (cdr best)) 827 (setq gnus-cite-loose-prefix-alist
648 current) 828 (delq best gnus-cite-loose-prefix-alist))
649 (setq gnus-cite-loose-prefix-alist 829 (while loop
650 (delq best gnus-cite-loose-prefix-alist)) 830 (setq current (car loop)
651 (while loop 831 loop (cdr loop))
652 (setq current (car loop) 832 (if (eq current best)
653 loop (cdr loop)) 833 ()
654 (if (eq current best) 834 (setcdr current (gnus-set-difference (cdr current) numbers))
655 () 835 (when (null (cdr current))
656 (setcdr current (gnus-set-difference (cdr current) numbers)) 836 (setq gnus-cite-loose-prefix-alist
657 (if (null (cdr current)) 837 (delq current gnus-cite-loose-prefix-alist)
658 (setq gnus-cite-loose-prefix-alist 838 atts (delq current atts)))))))))))
659 (delq current gnus-cite-loose-prefix-alist)
660 atts (delq current atts)))))))))))
661 839
662 (defun gnus-cite-find-loose (prefix) 840 (defun gnus-cite-find-loose (prefix)
663 ;; Return a list of loose attribution lines prefixed by PREFIX. 841 ;; Return a list of loose attribution lines prefixed by PREFIX.
664 (let* ((atts gnus-cite-loose-attribution-alist) 842 (let* ((atts gnus-cite-loose-attribution-alist)
665 att line lines) 843 att line lines)
666 (while atts 844 (while atts
667 (setq att (car atts) 845 (setq att (car atts)
668 line (car att) 846 line (car att)
669 atts (cdr atts)) 847 atts (cdr atts))
670 (if (string-equal (gnus-cite-find-prefix line) prefix) 848 (when (string-equal (gnus-cite-find-prefix line) prefix)
671 (setq lines (cons line lines)))) 849 (push line lines)))
672 lines)) 850 lines))
673 851
674 (defun gnus-cite-add-face (number prefix face) 852 (defun gnus-cite-add-face (number prefix face)
675 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. 853 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
676 (when face 854 (when face
677 (let ((inhibit-point-motion-hooks t) 855 (let ((inhibit-point-motion-hooks t)
678 from to) 856 from to)
679 (goto-line number) 857 (goto-line number)
680 (unless (eobp) ;; Sometimes things become confused. 858 (unless (eobp);; Sometimes things become confused.
681 (forward-char (length prefix)) 859 (forward-char (length prefix))
682 (skip-chars-forward " \t") 860 (skip-chars-forward " \t")
683 (setq from (point)) 861 (setq from (point))
684 (end-of-line 1) 862 (end-of-line 1)
685 (skip-chars-backward " \t") 863 (skip-chars-backward " \t")
703 gnus-hidden-properties)) 881 gnus-hidden-properties))
704 ((assq number gnus-cite-attribution-alist)) 882 ((assq number gnus-cite-attribution-alist))
705 (t 883 (t
706 (gnus-add-text-properties 884 (gnus-add-text-properties
707 (point) (progn (forward-line 1) (point)) 885 (point) (progn (forward-line 1) (point))
708 (nconc (list 'gnus-type 'cite) 886 (nconc (list 'article-type 'cite)
709 gnus-hidden-properties)))))))) 887 gnus-hidden-properties))))))))
710 888
711 (defun gnus-cite-find-prefix (line) 889 (defun gnus-cite-find-prefix (line)
712 ;; Return citation prefix for LINE. 890 ;; Return citation prefix for LINE.
713 (let ((alist gnus-cite-prefix-alist) 891 (let ((alist gnus-cite-prefix-alist)
714 (prefix "") 892 (prefix "")
715 entry) 893 entry)
716 (while alist 894 (while alist
717 (setq entry (car alist) 895 (setq entry (car alist)
718 alist (cdr alist)) 896 alist (cdr alist))
719 (if (memq line (cdr entry)) 897 (when (memq line (cdr entry))
720 (setq prefix (car entry)))) 898 (setq prefix (car entry))))
721 prefix)) 899 prefix))
722 900
723 (gnus-add-shutdown 'gnus-cache-close 'gnus) 901 (gnus-add-shutdown 'gnus-cache-close 'gnus)
724 902
725 (defun gnus-cache-close () 903 (defun gnus-cache-close ()