Commit | Line | Data |
---|---|---|
41487370 | 1 | ;;; gnus-cite.el --- parse citations in articles for Gnus |
231f989b | 2 | ;; Copyright (C) 1995,96 Free Software Foundation, Inc. |
41487370 LMI |
3 | |
4 | ;; Author: Per Abrahamsen <abraham@iesd.auc.dk> | |
5 | ;; Keywords: news, mail | |
6 | ||
7 | ;; This file is part of GNU Emacs. | |
8 | ||
9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 | ;; it under the terms of the GNU General Public License as published by | |
11 | ;; the Free Software Foundation; either version 2, or (at your option) | |
12 | ;; any later version. | |
13 | ||
14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;; GNU General Public License for more details. | |
18 | ||
19 | ;; You should have received a copy of the GNU General Public License | |
b578f267 EN |
20 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
21 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
22 | ;; Boston, MA 02111-1307, USA. | |
41487370 LMI |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;;; Code: | |
27 | ||
28 | (require 'gnus) | |
29 | (require 'gnus-msg) | |
30 | (require 'gnus-ems) | |
231f989b | 31 | (eval-when-compile (require 'cl)) |
41487370 LMI |
32 | |
33 | (eval-and-compile | |
231f989b | 34 | (autoload 'gnus-article-add-button "gnus-vis")) |
41487370 LMI |
35 | |
36 | ;;; Customization: | |
37 | ||
231f989b LMI |
38 | (defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n" |
39 | "Format of cited text buttons.") | |
40 | ||
41 | (defvar gnus-cited-lines-visible nil | |
42 | "The number of lines of hidden cited text to remain visible.") | |
43 | ||
41487370 LMI |
44 | (defvar gnus-cite-parse-max-size 25000 |
45 | "Maximum article size (in bytes) where parsing citations is allowed. | |
46 | Set it to nil to parse all articles.") | |
47 | ||
48 | (defvar gnus-cite-prefix-regexp | |
49 | "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" | |
50 | "Regexp matching the longest possible citation prefix on a line.") | |
51 | ||
52 | (defvar gnus-cite-max-prefix 20 | |
231f989b | 53 | "Maximum possible length for a citation prefix.") |
41487370 LMI |
54 | |
55 | (defvar gnus-supercite-regexp | |
56 | (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" | |
57 | ">>>>> +\"\\([^\"\n]+\\)\" +==") | |
231f989b LMI |
58 | "Regexp matching normal Supercite attribution lines. |
59 | The first grouping must match prefixes added by other packages.") | |
41487370 LMI |
60 | |
61 | (defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" | |
231f989b LMI |
62 | "Regexp matching mangled Supercite attribution lines. |
63 | The first regexp group should match the Supercite attribution.") | |
41487370 LMI |
64 | |
65 | (defvar gnus-cite-minimum-match-count 2 | |
231f989b | 66 | "Minimum number of identical prefixes before we believe it's a citation.") |
41487370 LMI |
67 | |
68 | ;see gnus-cus.el | |
69 | ;(defvar gnus-cite-face-list | |
70 | ; (if (eq gnus-display-type 'color) | |
71 | ; (if (eq gnus-background-mode 'dark) 'light 'dark) | |
72 | ; '(italic)) | |
73 | ; "Faces used for displaying different citations. | |
74 | ;It is either a list of face names, or one of the following special | |
75 | ;values: | |
76 | ||
77 | ;dark: Create faces from `gnus-face-dark-name-list'. | |
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 | ||
231f989b | 86 | (defvar gnus-cite-attribution-suffix |
41487370 LMI |
87 | "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$" |
88 | "Regexp matching the end of an attribution line. | |
89 | The text matching the first grouping will be used as a button.") | |
90 | ||
91 | ;see gnus-cus.el | |
92 | ;(defvar gnus-cite-attribution-face 'underline | |
93 | ; "Face used for attribution lines. | |
94 | ;It is merged with the face for the cited text belonging to the attribution.") | |
95 | ||
96 | ;see gnus-cus.el | |
97 | ;(defvar gnus-cite-hide-percentage 50 | |
98 | ; "Only hide cited text if it is larger than this percent of the body.") | |
99 | ||
100 | ;see gnus-cus.el | |
101 | ;(defvar gnus-cite-hide-absolute 10 | |
102 | ; "Only hide cited text if there is at least this number of cited lines.") | |
103 | ||
104 | ;see gnus-cus.el | |
105 | ;(defvar gnus-face-light-name-list | |
106 | ; '("light blue" "light cyan" "light yellow" "light pink" | |
107 | ; "pale green" "beige" "orange" "magenta" "violet" "medium purple" | |
108 | ; "turquoise") | |
109 | ; "Names of light colors.") | |
110 | ||
111 | ;see gnus-cus.el | |
112 | ;(defvar gnus-face-dark-name-list | |
113 | ; '("dark salmon" "firebrick" | |
114 | ; "dark green" "dark orange" "dark khaki" "dark violet" | |
115 | ; "dark turquoise") | |
116 | ; "Names of dark colors.") | |
117 | ||
118 | ;;; Internal Variables: | |
119 | ||
231f989b | 120 | (defvar gnus-cite-article nil) |
41487370 LMI |
121 | |
122 | (defvar gnus-cite-prefix-alist nil) | |
123 | ;; Alist of citation prefixes. | |
124 | ;; The cdr is a list of lines with that prefix. | |
125 | ||
126 | (defvar gnus-cite-attribution-alist nil) | |
127 | ;; Alist of attribution lines. | |
128 | ;; The car is a line number. | |
129 | ;; The cdr is the prefix for the citation started by that line. | |
130 | ||
131 | (defvar gnus-cite-loose-prefix-alist nil) | |
132 | ;; Alist of citation prefixes that have no matching attribution. | |
133 | ;; The cdr is a list of lines with that prefix. | |
134 | ||
135 | (defvar gnus-cite-loose-attribution-alist nil) | |
136 | ;; Alist of attribution lines that have no matching citation. | |
137 | ;; Each member has the form (WROTE IN PREFIX TAG), where | |
138 | ;; WROTE: is the attribution line number | |
139 | ;; 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 | |
231f989b LMI |
141 | ;; TAG: Is a Supercite tag, if any. |
142 | ||
143 | (defvar gnus-cited-text-button-line-format-alist | |
144 | `((?b beg ?d) | |
145 | (?e end ?d) | |
146 | (?l (- end beg) ?d))) | |
147 | (defvar gnus-cited-text-button-line-format-spec nil) | |
41487370 LMI |
148 | |
149 | ;;; Commands: | |
150 | ||
151 | (defun gnus-article-highlight-citation (&optional force) | |
152 | "Highlight cited text. | |
153 | Each citation in the article will be highlighted with a different face. | |
154 | The faces are taken from `gnus-cite-face-list'. | |
155 | Attribution lines are highlighted with the same face as the | |
156 | corresponding citation merged with `gnus-cite-attribution-face'. | |
157 | ||
158 | Text is considered cited if at least `gnus-cite-minimum-match-count' | |
159 | lines matches `gnus-cite-prefix-regexp' with the same prefix. | |
160 | ||
231f989b | 161 | Lines matching `gnus-cite-attribution-suffix' and perhaps |
41487370 LMI |
162 | `gnus-cite-attribution-prefix' are considered attribution lines." |
163 | (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 | |
172 | (set-buffer gnus-article-buffer) | |
173 | (gnus-cite-parse-maybe force) | |
174 | (let ((buffer-read-only nil) | |
175 | (alist gnus-cite-prefix-alist) | |
176 | (faces gnus-cite-face-list) | |
177 | (inhibit-point-motion-hooks t) | |
178 | face entry prefix skip numbers number face-alist) | |
179 | ;; Loop through citation prefixes. | |
180 | (while alist | |
181 | (setq entry (car alist) | |
182 | alist (cdr alist) | |
183 | prefix (car entry) | |
184 | numbers (cdr entry) | |
185 | face (car faces) | |
186 | faces (or (cdr faces) gnus-cite-face-list) | |
187 | face-alist (cons (cons prefix face) face-alist)) | |
188 | (while numbers | |
189 | (setq number (car numbers) | |
190 | numbers (cdr numbers)) | |
191 | (and (not (assq number gnus-cite-attribution-alist)) | |
192 | (not (assq number gnus-cite-loose-attribution-alist)) | |
193 | (gnus-cite-add-face number prefix face)))) | |
194 | ;; Loop through attribution lines. | |
195 | (setq alist gnus-cite-attribution-alist) | |
196 | (while alist | |
197 | (setq entry (car alist) | |
198 | alist (cdr alist) | |
199 | number (car entry) | |
200 | prefix (cdr entry) | |
201 | skip (gnus-cite-find-prefix number) | |
202 | face (cdr (assoc prefix face-alist))) | |
203 | ;; Add attribution button. | |
204 | (goto-line number) | |
231f989b | 205 | (if (re-search-forward gnus-cite-attribution-suffix |
41487370 LMI |
206 | (save-excursion (end-of-line 1) (point)) |
207 | t) | |
208 | (gnus-article-add-button (match-beginning 1) (match-end 1) | |
209 | 'gnus-cite-toggle prefix)) | |
210 | ;; Highlight attribution line. | |
211 | (gnus-cite-add-face number skip face) | |
212 | (gnus-cite-add-face number skip gnus-cite-attribution-face)) | |
213 | ;; Loop through attribution lines. | |
214 | (setq alist gnus-cite-loose-attribution-alist) | |
215 | (while alist | |
216 | (setq entry (car alist) | |
217 | alist (cdr alist) | |
218 | number (car entry) | |
219 | skip (gnus-cite-find-prefix number)) | |
220 | (gnus-cite-add-face number skip gnus-cite-attribution-face))))) | |
221 | ||
231f989b LMI |
222 | (defun gnus-dissect-cited-text () |
223 | "Dissect the article buffer looking for cited text." | |
41487370 LMI |
224 | (save-excursion |
225 | (set-buffer gnus-article-buffer) | |
231f989b LMI |
226 | (gnus-cite-parse-maybe) |
227 | (let ((alist gnus-cite-prefix-alist) | |
228 | prefix numbers number marks m) | |
229 | ;; Loop through citation prefixes. | |
41487370 | 230 | (while alist |
231f989b LMI |
231 | (setq numbers (pop alist) |
232 | prefix (pop numbers)) | |
41487370 | 233 | (while numbers |
231f989b LMI |
234 | (setq number (pop numbers)) |
235 | (goto-char (point-min)) | |
236 | (forward-line number) | |
237 | (push (cons (point-marker) "") marks) | |
238 | (while (and numbers | |
239 | (= (1- number) (car numbers))) | |
240 | (setq number (pop numbers))) | |
241 | (goto-char (point-min)) | |
242 | (forward-line (1- number)) | |
243 | (push (cons (point-marker) prefix) marks))) | |
244 | (goto-char (point-min)) | |
245 | (search-forward "\n\n" nil t) | |
246 | (push (cons (point-marker) "") marks) | |
247 | (goto-char (point-max)) | |
248 | (re-search-backward gnus-signature-separator nil t) | |
249 | (push (cons (point-marker) "") marks) | |
250 | (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) | |
251 | (let* ((omarks marks)) | |
252 | (setq marks nil) | |
253 | (while (cdr omarks) | |
254 | (if (= (caar omarks) (caadr omarks)) | |
255 | (progn | |
256 | (unless (equal (cdar omarks) "") | |
257 | (push (car omarks) marks)) | |
258 | (unless (equal (cdadr omarks) "") | |
259 | (push (cadr omarks) marks)) | |
260 | (setq omarks (cdr omarks))) | |
261 | (push (car omarks) marks)) | |
262 | (setq omarks (cdr omarks))) | |
263 | (when (car omarks) | |
264 | (push (car omarks) marks)) | |
265 | (setq marks (setq m (nreverse marks))) | |
266 | (while (cddr m) | |
267 | (if (and (equal (cdadr m) "") | |
268 | (equal (cdar m) (cdaddr m)) | |
269 | (goto-char (caadr m)) | |
270 | (forward-line 1) | |
271 | (= (point) (caaddr m))) | |
272 | (setcdr m (cdddr m)) | |
273 | (setq m (cdr m)))) | |
274 | marks)))) | |
275 | ||
276 | ||
277 | (defun gnus-article-fill-cited-article (&optional force) | |
278 | "Do word wrapping in the current article." | |
279 | (interactive (list t)) | |
280 | (save-excursion | |
281 | (set-buffer gnus-article-buffer) | |
282 | (let ((buffer-read-only nil) | |
283 | (inhibit-point-motion-hooks t) | |
284 | (marks (gnus-dissect-cited-text)) | |
285 | (adaptive-fill-mode nil)) | |
286 | (save-restriction | |
287 | (while (cdr marks) | |
288 | (widen) | |
289 | (narrow-to-region (caar marks) (caadr marks)) | |
290 | (let ((adaptive-fill-regexp | |
291 | (concat "^" (regexp-quote (cdar marks)) " *")) | |
292 | (fill-prefix (cdar marks))) | |
293 | (fill-region (point-min) (point-max))) | |
294 | (set-marker (caar marks) nil) | |
295 | (setq marks (cdr marks))) | |
296 | (when marks | |
297 | (set-marker (caar marks) nil)))))) | |
298 | ||
299 | (defun gnus-article-hide-citation (&optional arg force) | |
300 | "Toggle hiding of all cited text except attribution lines. | |
301 | See the documentation for `gnus-article-highlight-citation'. | |
302 | If given a negative prefix, always show; if given a positive prefix, | |
303 | always hide." | |
304 | (interactive (append (gnus-hidden-arg) (list 'force))) | |
305 | (setq gnus-cited-text-button-line-format-spec | |
306 | (gnus-parse-format gnus-cited-text-button-line-format | |
307 | gnus-cited-text-button-line-format-alist t)) | |
308 | (unless (gnus-article-check-hidden-text 'cite arg) | |
309 | (save-excursion | |
310 | (set-buffer gnus-article-buffer) | |
311 | (let ((buffer-read-only nil) | |
312 | (marks (gnus-dissect-cited-text)) | |
313 | (inhibit-point-motion-hooks t) | |
314 | (props (nconc (list 'gnus-type 'cite) | |
315 | gnus-hidden-properties)) | |
316 | beg end) | |
317 | (while marks | |
318 | (setq beg nil | |
319 | end nil) | |
320 | (while (and marks (string= (cdar marks) "")) | |
321 | (setq marks (cdr marks))) | |
322 | (when marks | |
323 | (setq beg (caar marks))) | |
324 | (while (and marks (not (string= (cdar marks) ""))) | |
325 | (setq marks (cdr marks))) | |
326 | (when marks | |
327 | (setq end (caar marks))) | |
328 | ;; Skip past lines we want to leave visible. | |
329 | (when (and beg end gnus-cited-lines-visible) | |
330 | (goto-char beg) | |
331 | (forward-line gnus-cited-lines-visible) | |
332 | (if (>= (point) end) | |
333 | (setq beg nil) | |
334 | (setq beg (point-marker)))) | |
335 | (when (and beg end) | |
336 | (gnus-add-text-properties beg end props) | |
337 | (goto-char beg) | |
338 | (unless (save-excursion (search-backward "\n\n" nil t)) | |
339 | (insert "\n")) | |
340 | (gnus-article-add-button | |
341 | (point) | |
342 | (progn (eval gnus-cited-text-button-line-format-spec) (point)) | |
343 | `gnus-article-toggle-cited-text (cons beg end)) | |
344 | (set-marker beg (point)))))))) | |
345 | ||
346 | (defun gnus-article-toggle-cited-text (region) | |
347 | "Toggle hiding the text in REGION." | |
348 | (let (buffer-read-only) | |
349 | (funcall | |
350 | (if (text-property-any | |
351 | (car region) (1- (cdr region)) | |
352 | (car gnus-hidden-properties) (cadr gnus-hidden-properties)) | |
353 | 'remove-text-properties 'gnus-add-text-properties) | |
354 | (car region) (cdr region) gnus-hidden-properties))) | |
355 | ||
356 | (defun gnus-article-hide-citation-maybe (&optional arg force) | |
357 | "Toggle hiding of cited text that has an attribution line. | |
358 | If given a negative prefix, always show; if given a positive prefix, | |
359 | always hide. | |
41487370 LMI |
360 | 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 | |
362 | cited text with attributions. When called interactively, these two | |
363 | variables are ignored. | |
364 | See also the documentation for `gnus-article-highlight-citation'." | |
231f989b LMI |
365 | (interactive (append (gnus-hidden-arg) (list 'force))) |
366 | (unless (gnus-article-check-hidden-text 'cite arg) | |
367 | (save-excursion | |
368 | (set-buffer gnus-article-buffer) | |
369 | (gnus-cite-parse-maybe force) | |
370 | (goto-char (point-min)) | |
371 | (search-forward "\n\n" nil t) | |
372 | (let ((start (point)) | |
373 | (atts gnus-cite-attribution-alist) | |
374 | (buffer-read-only nil) | |
375 | (inhibit-point-motion-hooks t) | |
376 | (hiden 0) | |
377 | total) | |
378 | (goto-char (point-max)) | |
379 | (re-search-backward gnus-signature-separator nil t) | |
380 | (setq total (count-lines start (point))) | |
381 | (while atts | |
382 | (setq hiden (+ hiden (length (cdr (assoc (cdar atts) | |
383 | gnus-cite-prefix-alist)))) | |
384 | atts (cdr atts))) | |
385 | (if (or force | |
386 | (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) | |
387 | (> hiden gnus-cite-hide-absolute))) | |
388 | (progn | |
389 | (setq atts gnus-cite-attribution-alist) | |
390 | (while atts | |
391 | (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) | |
392 | atts (cdr atts)) | |
393 | (while total | |
394 | (setq hiden (car total) | |
395 | total (cdr total)) | |
396 | (goto-line hiden) | |
397 | (or (assq hiden gnus-cite-attribution-alist) | |
398 | (gnus-add-text-properties | |
399 | (point) (progn (forward-line 1) (point)) | |
400 | (nconc (list 'gnus-type 'cite) | |
401 | gnus-hidden-properties))))))))))) | |
402 | ||
403 | (defun gnus-article-hide-citation-in-followups () | |
404 | "Hide cited text in non-root articles." | |
405 | (interactive) | |
41487370 LMI |
406 | (save-excursion |
407 | (set-buffer gnus-article-buffer) | |
231f989b LMI |
408 | (let ((article (cdr gnus-article-current))) |
409 | (unless (save-excursion | |
410 | (set-buffer gnus-summary-buffer) | |
411 | (gnus-article-displayed-root-p article)) | |
412 | (gnus-article-hide-citation))))) | |
41487370 LMI |
413 | |
414 | ;;; Internal functions: | |
415 | ||
416 | (defun gnus-cite-parse-maybe (&optional force) | |
417 | ;; Parse if the buffer has changes since last time. | |
231f989b | 418 | (if (equal gnus-cite-article gnus-article-current) |
41487370 LMI |
419 | () |
420 | ;;Reset parser information. | |
421 | (setq gnus-cite-prefix-alist nil | |
422 | gnus-cite-attribution-alist nil | |
423 | gnus-cite-loose-prefix-alist nil | |
424 | gnus-cite-loose-attribution-alist nil) | |
425 | ;; Parse if not too large. | |
426 | (if (and (not force) | |
427 | gnus-cite-parse-max-size | |
428 | (> (buffer-size) gnus-cite-parse-max-size)) | |
429 | () | |
231f989b LMI |
430 | (setq gnus-cite-article (cons (car gnus-article-current) |
431 | (cdr gnus-article-current))) | |
41487370 LMI |
432 | (gnus-cite-parse)))) |
433 | ||
434 | (defun gnus-cite-parse () | |
435 | ;; Parse and connect citation prefixes and attribution lines. | |
436 | ||
437 | ;; 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)))) | |
442 | (case-fold-search t) | |
443 | (max (save-excursion | |
444 | (goto-char (point-max)) | |
445 | (re-search-backward gnus-signature-separator nil t) | |
446 | (point))) | |
447 | alist entry start begin end numbers prefix) | |
448 | ;; Get all potential prefixes in `alist'. | |
449 | (while (< (point) max) | |
450 | ;; Each line. | |
451 | (setq begin (point) | |
452 | end (progn (beginning-of-line 2) (point)) | |
453 | start end) | |
454 | (goto-char begin) | |
231f989b | 455 | ;; Ignore standard Supercite attribution prefix. |
41487370 LMI |
456 | (if (looking-at gnus-supercite-regexp) |
457 | (if (match-end 1) | |
458 | (setq end (1+ (match-end 1))) | |
459 | (setq end (1+ begin)))) | |
460 | ;; Ignore very long prefixes. | |
461 | (if (> end (+ (point) gnus-cite-max-prefix)) | |
462 | (setq end (+ (point) gnus-cite-max-prefix))) | |
463 | (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) | |
464 | ;; Each prefix. | |
465 | (setq end (match-end 0) | |
466 | prefix (buffer-substring begin end)) | |
231f989b | 467 | (gnus-set-text-properties 0 (length prefix) nil prefix) |
41487370 LMI |
468 | (setq entry (assoc prefix alist)) |
469 | (if entry | |
470 | (setcdr entry (cons line (cdr entry))) | |
471 | (setq alist (cons (list prefix line) alist))) | |
472 | (goto-char begin)) | |
473 | (goto-char start) | |
474 | (setq line (1+ line))) | |
475 | ;; We got all the potential prefixes. Now create | |
476 | ;; `gnus-cite-prefix-alist' containing the oldest prefix for each | |
477 | ;; line that appears at least gnus-cite-minimum-match-count | |
478 | ;; times. First sort them by length. Longer is older. | |
479 | (setq alist (sort alist (lambda (a b) | |
480 | (> (length (car a)) (length (car b)))))) | |
481 | (while alist | |
482 | (setq entry (car alist) | |
483 | prefix (car entry) | |
484 | numbers (cdr entry) | |
485 | alist (cdr alist)) | |
486 | (cond ((null numbers) | |
487 | ;; No lines with this prefix that wasn't also part of | |
488 | ;; a longer prefix. | |
489 | ) | |
490 | ((< (length numbers) gnus-cite-minimum-match-count) | |
491 | ;; Too few lines with this prefix. We keep it a bit | |
492 | ;; longer in case it is an exact match for an attribution | |
493 | ;; line, but we don't remove the line from other | |
494 | ;; prefixes. | |
495 | (setq gnus-cite-prefix-alist | |
496 | (cons entry gnus-cite-prefix-alist))) | |
497 | (t | |
498 | (setq gnus-cite-prefix-alist (cons entry | |
499 | gnus-cite-prefix-alist)) | |
500 | ;; Remove articles from other prefixes. | |
501 | (let ((loop alist) | |
502 | current) | |
503 | (while loop | |
504 | (setq current (car loop) | |
505 | loop (cdr loop)) | |
506 | (setcdr current | |
507 | (gnus-set-difference (cdr current) numbers)))))))) | |
508 | ;; No citations have been connected to attribution lines yet. | |
509 | (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) | |
510 | ||
511 | ;; Parse current buffer searching for attribution lines. | |
512 | (goto-char (point-min)) | |
513 | (search-forward "\n\n" nil t) | |
231f989b | 514 | (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) |
41487370 LMI |
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) | |
231f989b | 532 | (not (re-search-forward gnus-cite-attribution-suffix |
41487370 LMI |
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. | |
542 | (gnus-cite-match-attributions 'small nil | |
543 | (lambda (prefix tag) | |
544 | (if tag | |
545 | (concat "\\`" | |
546 | (regexp-quote prefix) "[ \t]*" | |
547 | (regexp-quote tag) ">")))) | |
548 | ;; Find loose supercite citations after attributions. | |
549 | (gnus-cite-match-attributions 'small t | |
550 | (lambda (prefix tag) | |
551 | (if tag (concat "\\<" | |
552 | (regexp-quote tag) | |
553 | "\\>")))) | |
554 | ;; Find loose supercite citations anywhere. | |
555 | (gnus-cite-match-attributions 'small nil | |
556 | (lambda (prefix tag) | |
557 | (if tag (concat "\\<" | |
558 | (regexp-quote tag) | |
559 | "\\>")))) | |
560 | ;; Find nested citations after attributions. | |
561 | (gnus-cite-match-attributions 'small-if-unique t | |
562 | (lambda (prefix tag) | |
563 | (concat "\\`" (regexp-quote prefix) ".+"))) | |
564 | ;; Find nested citations anywhere. | |
565 | (gnus-cite-match-attributions 'small nil | |
566 | (lambda (prefix tag) | |
567 | (concat "\\`" (regexp-quote prefix) ".+"))) | |
568 | ;; Remove loose prefixes with too few lines. | |
569 | (let ((alist gnus-cite-loose-prefix-alist) | |
570 | entry) | |
571 | (while alist | |
572 | (setq entry (car alist) | |
573 | alist (cdr alist)) | |
574 | (if (< (length (cdr entry)) gnus-cite-minimum-match-count) | |
575 | (setq gnus-cite-prefix-alist | |
576 | (delq entry gnus-cite-prefix-alist) | |
577 | gnus-cite-loose-prefix-alist | |
578 | (delq entry gnus-cite-loose-prefix-alist))))) | |
579 | ;; Find flat attributions. | |
580 | (gnus-cite-match-attributions 'first t nil) | |
581 | ;; Find any attributions (are we getting desperate yet?). | |
582 | (gnus-cite-match-attributions 'first nil nil)) | |
583 | ||
584 | (defun gnus-cite-match-attributions (sort after fun) | |
585 | ;; Match all loose attributions and citations (SORT AFTER FUN) . | |
586 | ;; | |
587 | ;; If SORT is `small', the citation with the shortest prefix will be | |
588 | ;; used, if it is `first' the first prefix will be used, if it is | |
589 | ;; `small-if-unique' the shortest prefix will be used if the | |
590 | ;; attribution line does not share its own prefix with other | |
591 | ;; loose attribution lines, otherwise the first prefix will be used. | |
592 | ;; | |
593 | ;; If AFTER is non-nil, only citations after the attribution line | |
a7acbbe4 | 594 | ;; will be considered. |
41487370 LMI |
595 | ;; |
596 | ;; If FUN is non-nil, it will be called with the arguments (WROTE | |
597 | ;; PREFIX TAG) and expected to return a regular expression. Only | |
598 | ;; citations whose prefix matches the regular expression will be | |
a7acbbe4 | 599 | ;; considered. |
41487370 LMI |
600 | ;; |
601 | ;; WROTE is the attribution line number. | |
602 | ;; PREFIX is the attribution line prefix. | |
231f989b | 603 | ;; TAG is the Supercite tag on the attribution line. |
41487370 LMI |
604 | (let ((atts gnus-cite-loose-attribution-alist) |
605 | (case-fold-search t) | |
606 | att wrote in prefix tag regexp limit smallest best size) | |
607 | (while atts | |
608 | (setq att (car atts) | |
609 | atts (cdr atts) | |
610 | wrote (nth 0 att) | |
611 | in (nth 1 att) | |
612 | prefix (nth 2 att) | |
613 | tag (nth 3 att) | |
614 | regexp (if fun (funcall fun prefix tag) "") | |
615 | size (cond ((eq sort 'small) t) | |
616 | ((eq sort 'first) nil) | |
617 | (t (< (length (gnus-cite-find-loose prefix)) 2))) | |
618 | limit (if after wrote -1) | |
619 | smallest 1000000 | |
620 | best nil) | |
621 | (let ((cites gnus-cite-loose-prefix-alist) | |
622 | cite candidate numbers first compare) | |
623 | (while cites | |
624 | (setq cite (car cites) | |
625 | cites (cdr cites) | |
626 | candidate (car cite) | |
627 | numbers (cdr cite) | |
628 | first (apply 'min numbers) | |
629 | compare (if size (length candidate) first)) | |
630 | (and (> first limit) | |
631 | regexp | |
632 | (string-match regexp candidate) | |
633 | (< compare smallest) | |
634 | (setq best cite | |
635 | smallest compare)))) | |
636 | (if (null best) | |
637 | () | |
638 | (setq gnus-cite-loose-attribution-alist | |
639 | (delq att gnus-cite-loose-attribution-alist)) | |
640 | (setq gnus-cite-attribution-alist | |
641 | (cons (cons wrote (car best)) gnus-cite-attribution-alist)) | |
642 | (if in | |
643 | (setq gnus-cite-attribution-alist | |
644 | (cons (cons in (car best)) gnus-cite-attribution-alist))) | |
645 | (if (memq best gnus-cite-loose-prefix-alist) | |
646 | (let ((loop gnus-cite-prefix-alist) | |
647 | (numbers (cdr best)) | |
648 | current) | |
649 | (setq gnus-cite-loose-prefix-alist | |
650 | (delq best gnus-cite-loose-prefix-alist)) | |
651 | (while loop | |
652 | (setq current (car loop) | |
653 | loop (cdr loop)) | |
654 | (if (eq current best) | |
655 | () | |
656 | (setcdr current (gnus-set-difference (cdr current) numbers)) | |
657 | (if (null (cdr current)) | |
658 | (setq gnus-cite-loose-prefix-alist | |
659 | (delq current gnus-cite-loose-prefix-alist) | |
660 | atts (delq current atts))))))))))) | |
661 | ||
662 | (defun gnus-cite-find-loose (prefix) | |
663 | ;; Return a list of loose attribution lines prefixed by PREFIX. | |
664 | (let* ((atts gnus-cite-loose-attribution-alist) | |
665 | att line lines) | |
666 | (while atts | |
667 | (setq att (car atts) | |
668 | line (car att) | |
669 | atts (cdr atts)) | |
670 | (if (string-equal (gnus-cite-find-prefix line) prefix) | |
671 | (setq lines (cons line lines)))) | |
672 | lines)) | |
673 | ||
674 | (defun gnus-cite-add-face (number prefix face) | |
675 | ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. | |
231f989b LMI |
676 | (when face |
677 | (let ((inhibit-point-motion-hooks t) | |
678 | from to) | |
679 | (goto-line number) | |
680 | (unless (eobp) ;; Sometimes things become confused. | |
41487370 LMI |
681 | (forward-char (length prefix)) |
682 | (skip-chars-forward " \t") | |
683 | (setq from (point)) | |
684 | (end-of-line 1) | |
685 | (skip-chars-backward " \t") | |
686 | (setq to (point)) | |
231f989b LMI |
687 | (when (< from to) |
688 | (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) | |
41487370 LMI |
689 | |
690 | (defun gnus-cite-toggle (prefix) | |
691 | (save-excursion | |
692 | (set-buffer gnus-article-buffer) | |
693 | (let ((buffer-read-only nil) | |
694 | (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) | |
695 | (inhibit-point-motion-hooks t) | |
696 | number) | |
697 | (while numbers | |
698 | (setq number (car numbers) | |
699 | numbers (cdr numbers)) | |
700 | (goto-line number) | |
701 | (cond ((get-text-property (point) 'invisible) | |
702 | (remove-text-properties (point) (progn (forward-line 1) (point)) | |
703 | gnus-hidden-properties)) | |
704 | ((assq number gnus-cite-attribution-alist)) | |
705 | (t | |
231f989b LMI |
706 | (gnus-add-text-properties |
707 | (point) (progn (forward-line 1) (point)) | |
708 | (nconc (list 'gnus-type 'cite) | |
709 | gnus-hidden-properties)))))))) | |
41487370 LMI |
710 | |
711 | (defun gnus-cite-find-prefix (line) | |
712 | ;; Return citation prefix for LINE. | |
713 | (let ((alist gnus-cite-prefix-alist) | |
714 | (prefix "") | |
715 | entry) | |
716 | (while alist | |
717 | (setq entry (car alist) | |
718 | alist (cdr alist)) | |
719 | (if (memq line (cdr entry)) | |
720 | (setq prefix (car entry)))) | |
721 | prefix)) | |
722 | ||
231f989b LMI |
723 | (gnus-add-shutdown 'gnus-cache-close 'gnus) |
724 | ||
725 | (defun gnus-cache-close () | |
726 | (setq gnus-cite-prefix-alist nil)) | |
727 | ||
41487370 LMI |
728 | (gnus-ems-redefine) |
729 | ||
730 | (provide 'gnus-cite) | |
731 | ||
732 | ;;; gnus-cite.el ends here |