1 ;;; gnus-cite.el --- parse citations in articles for Gnus
3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
5 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
6 ;; Keywords: news, mail
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
34 (autoload 'gnus-article-add-button
"gnus-vis")
39 (defvar gnus-cite-parse-max-size
25000
40 "Maximum article size (in bytes) where parsing citations is allowed.
41 Set it to nil to parse all articles.")
43 (defvar gnus-cite-prefix-regexp
44 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
45 "Regexp matching the longest possible citation prefix on a line.")
47 (defvar gnus-cite-max-prefix
20
48 "Maximal possible length for a citation prefix.")
50 (defvar gnus-supercite-regexp
51 (concat "^\\(" gnus-cite-prefix-regexp
"\\)? *"
52 ">>>>> +\"\\([^\"\n]+\\)\" +==")
53 "Regexp matching normal SuperCite attribution lines.
54 The first regexp group should match a prefix added by another package.")
56 (defvar gnus-supercite-secondary-regexp
"^.*\"\\([^\"\n]+\\)\" +=="
57 "Regexp matching mangled SuperCite attribution lines.
58 The first regexp group should match the SuperCite attribution.")
60 (defvar gnus-cite-minimum-match-count
2
61 "Minimal number of identical prefix'es before we believe it is a citation.")
64 ;(defvar gnus-cite-face-list
65 ; (if (eq gnus-display-type 'color)
66 ; (if (eq gnus-background-mode 'dark) 'light 'dark)
68 ; "Faces used for displaying different citations.
69 ;It is either a list of face names, or one of the following special
72 ;dark: Create faces from `gnus-face-dark-name-list'.
73 ;light: Create faces from `gnus-face-light-name-list'.
75 ;The variable `gnus-make-foreground' determines whether the created
76 ;faces change the foreground or the background colors.")
78 (defvar gnus-cite-attribution-prefix
"in article\\|in <"
79 "Regexp matching the beginning of an attribution line.")
81 (defvar gnus-cite-attribution-postfix
82 "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
83 "Regexp matching the end of an attribution line.
84 The text matching the first grouping will be used as a button.")
87 ;(defvar gnus-cite-attribution-face 'underline
88 ; "Face used for attribution lines.
89 ;It is merged with the face for the cited text belonging to the attribution.")
92 ;(defvar gnus-cite-hide-percentage 50
93 ; "Only hide cited text if it is larger than this percent of the body.")
96 ;(defvar gnus-cite-hide-absolute 10
97 ; "Only hide cited text if there is at least this number of cited lines.")
100 ;(defvar gnus-face-light-name-list
101 ; '("light blue" "light cyan" "light yellow" "light pink"
102 ; "pale green" "beige" "orange" "magenta" "violet" "medium purple"
104 ; "Names of light colors.")
107 ;(defvar gnus-face-dark-name-list
108 ; '("dark salmon" "firebrick"
109 ; "dark green" "dark orange" "dark khaki" "dark violet"
111 ; "Names of dark colors.")
113 ;;; Internal Variables:
115 (defvar gnus-article-length nil
)
116 ;; Length of article last time we parsed it.
117 ;; BUG! KLUDGE! UGLY! FIX ME!
119 (defvar gnus-cite-prefix-alist nil
)
120 ;; Alist of citation prefixes.
121 ;; The cdr is a list of lines with that prefix.
123 (defvar gnus-cite-attribution-alist nil
)
124 ;; Alist of attribution lines.
125 ;; The car is a line number.
126 ;; The cdr is the prefix for the citation started by that line.
128 (defvar gnus-cite-loose-prefix-alist nil
)
129 ;; Alist of citation prefixes that have no matching attribution.
130 ;; The cdr is a list of lines with that prefix.
132 (defvar gnus-cite-loose-attribution-alist nil
)
133 ;; Alist of attribution lines that have no matching citation.
134 ;; Each member has the form (WROTE IN PREFIX TAG), where
135 ;; WROTE: is the attribution line number
136 ;; IN: is the line number of the previous line if part of the same attribution,
137 ;; PREFIX: Is the citation prefix of the attribution line(s), and
138 ;; TAG: Is a SuperCite tag, if any.
142 (defun gnus-article-highlight-citation (&optional force
)
143 "Highlight cited text.
144 Each citation in the article will be highlighted with a different face.
145 The faces are taken from `gnus-cite-face-list'.
146 Attribution lines are highlighted with the same face as the
147 corresponding citation merged with `gnus-cite-attribution-face'.
149 Text is considered cited if at least `gnus-cite-minimum-match-count'
150 lines matches `gnus-cite-prefix-regexp' with the same prefix.
152 Lines matching `gnus-cite-attribution-postfix' and perhaps
153 `gnus-cite-attribution-prefix' are considered attribution lines."
154 (interactive (list 'force
))
155 ;; Create dark or light faces if necessary.
156 (cond ((eq gnus-cite-face-list
'light
)
157 (setq gnus-cite-face-list
158 (mapcar 'gnus-make-face gnus-face-light-name-list
)))
159 ((eq gnus-cite-face-list
'dark
)
160 (setq gnus-cite-face-list
161 (mapcar 'gnus-make-face gnus-face-dark-name-list
))))
163 (set-buffer gnus-article-buffer
)
164 (gnus-cite-parse-maybe force
)
165 (let ((buffer-read-only nil
)
166 (alist gnus-cite-prefix-alist
)
167 (faces gnus-cite-face-list
)
168 (inhibit-point-motion-hooks t
)
169 face entry prefix skip numbers number face-alist
)
170 ;; Loop through citation prefixes.
172 (setq entry
(car alist
)
177 faces
(or (cdr faces
) gnus-cite-face-list
)
178 face-alist
(cons (cons prefix face
) face-alist
))
180 (setq number
(car numbers
)
181 numbers
(cdr numbers
))
182 (and (not (assq number gnus-cite-attribution-alist
))
183 (not (assq number gnus-cite-loose-attribution-alist
))
184 (gnus-cite-add-face number prefix face
))))
185 ;; Loop through attribution lines.
186 (setq alist gnus-cite-attribution-alist
)
188 (setq entry
(car alist
)
192 skip
(gnus-cite-find-prefix number
)
193 face
(cdr (assoc prefix face-alist
)))
194 ;; Add attribution button.
196 (if (re-search-forward gnus-cite-attribution-postfix
197 (save-excursion (end-of-line 1) (point))
199 (gnus-article-add-button (match-beginning 1) (match-end 1)
200 'gnus-cite-toggle prefix
))
201 ;; Highlight attribution line.
202 (gnus-cite-add-face number skip face
)
203 (gnus-cite-add-face number skip gnus-cite-attribution-face
))
204 ;; Loop through attribution lines.
205 (setq alist gnus-cite-loose-attribution-alist
)
207 (setq entry
(car alist
)
210 skip
(gnus-cite-find-prefix number
))
211 (gnus-cite-add-face number skip gnus-cite-attribution-face
)))))
213 (defun gnus-article-hide-citation (&optional force
)
214 "Hide all cited text except attribution lines.
215 See the documentation for `gnus-article-highlight-citation'."
216 (interactive (list 'force
))
218 (set-buffer gnus-article-buffer
)
219 (gnus-cite-parse-maybe force
)
220 (let ((buffer-read-only nil
)
221 (alist gnus-cite-prefix-alist
)
222 (inhibit-point-motion-hooks t
)
225 (setq numbers
(cdr (car alist
))
228 (setq number
(car numbers
)
229 numbers
(cdr numbers
))
231 (or (assq number gnus-cite-attribution-alist
)
232 (add-text-properties (point) (progn (forward-line 1) (point))
233 gnus-hidden-properties
)))))))
235 (defun gnus-article-hide-citation-maybe (&optional force
)
236 "Hide cited text that has an attribution line.
237 This will do nothing unless at least `gnus-cite-hide-percentage'
238 percent and at least `gnus-cite-hide-absolute' lines of the body is
239 cited text with attributions. When called interactively, these two
240 variables are ignored.
241 See also the documentation for `gnus-article-highlight-citation'."
242 (interactive (list 'force
))
244 (set-buffer gnus-article-buffer
)
245 (gnus-cite-parse-maybe force
)
246 (goto-char (point-min))
247 (search-forward "\n\n" nil t
)
248 (let ((start (point))
249 (atts gnus-cite-attribution-alist
)
250 (buffer-read-only nil
)
251 (inhibit-point-motion-hooks t
)
254 (goto-char (point-max))
255 (re-search-backward gnus-signature-separator nil t
)
256 (setq total
(count-lines start
(point)))
258 (setq hiden
(+ hiden
(length (cdr (assoc (cdr (car atts
))
259 gnus-cite-prefix-alist
))))
262 (and (> (* 100 hiden
) (* gnus-cite-hide-percentage total
))
263 (> hiden gnus-cite-hide-absolute
)))
265 (setq atts gnus-cite-attribution-alist
)
267 (setq total
(cdr (assoc (cdr (car atts
)) gnus-cite-prefix-alist
))
270 (setq hiden
(car total
)
273 (or (assq hiden gnus-cite-attribution-alist
)
274 (add-text-properties (point)
275 (progn (forward-line 1) (point))
276 gnus-hidden-properties
)))))))))
278 ;;; Internal functions:
280 (defun gnus-cite-parse-maybe (&optional force
)
281 ;; Parse if the buffer has changes since last time.
282 (if (eq gnus-article-length
(- (point-max) (point-min)))
284 ;;Reset parser information.
285 (setq gnus-cite-prefix-alist nil
286 gnus-cite-attribution-alist nil
287 gnus-cite-loose-prefix-alist nil
288 gnus-cite-loose-attribution-alist nil
)
289 ;; Parse if not too large.
291 gnus-cite-parse-max-size
292 (> (buffer-size) gnus-cite-parse-max-size
))
294 (setq gnus-article-length
(- (point-max) (point-min)))
297 (defun gnus-cite-parse ()
298 ;; Parse and connect citation prefixes and attribution lines.
300 ;; Parse current buffer searching for citation prefixes.
301 (goto-char (point-min))
302 (or (search-forward "\n\n" nil t
)
303 (goto-char (point-max)))
304 (let ((line (1+ (count-lines (point-min) (point))))
307 (goto-char (point-max))
308 (re-search-backward gnus-signature-separator nil t
)
310 alist entry start begin end numbers prefix
)
311 ;; Get all potential prefixes in `alist'.
312 (while (< (point) max
)
315 end
(progn (beginning-of-line 2) (point))
318 ;; Ignore standard SuperCite attribution prefix.
319 (if (looking-at gnus-supercite-regexp
)
321 (setq end
(1+ (match-end 1)))
322 (setq end
(1+ begin
))))
323 ;; Ignore very long prefixes.
324 (if (> end
(+ (point) gnus-cite-max-prefix
))
325 (setq end
(+ (point) gnus-cite-max-prefix
)))
326 (while (re-search-forward gnus-cite-prefix-regexp
(1- end
) t
)
328 (setq end
(match-end 0)
329 prefix
(buffer-substring begin end
))
330 (set-text-properties 0 (length prefix
) nil prefix
)
331 (setq entry
(assoc prefix alist
))
333 (setcdr entry
(cons line
(cdr entry
)))
334 (setq alist
(cons (list prefix line
) alist
)))
337 (setq line
(1+ line
)))
338 ;; We got all the potential prefixes. Now create
339 ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
340 ;; line that appears at least gnus-cite-minimum-match-count
341 ;; times. First sort them by length. Longer is older.
342 (setq alist
(sort alist
(lambda (a b
)
343 (> (length (car a
)) (length (car b
))))))
345 (setq entry
(car alist
)
349 (cond ((null numbers
)
350 ;; No lines with this prefix that wasn't also part of
353 ((< (length numbers
) gnus-cite-minimum-match-count
)
354 ;; Too few lines with this prefix. We keep it a bit
355 ;; longer in case it is an exact match for an attribution
356 ;; line, but we don't remove the line from other
358 (setq gnus-cite-prefix-alist
359 (cons entry gnus-cite-prefix-alist
)))
361 (setq gnus-cite-prefix-alist
(cons entry
362 gnus-cite-prefix-alist
))
363 ;; Remove articles from other prefixes.
367 (setq current
(car loop
)
370 (gnus-set-difference (cdr current
) numbers
))))))))
371 ;; No citations have been connected to attribution lines yet.
372 (setq gnus-cite-loose-prefix-alist
(append gnus-cite-prefix-alist nil
))
374 ;; Parse current buffer searching for attribution lines.
375 (goto-char (point-min))
376 (search-forward "\n\n" nil t
)
377 (while (re-search-forward gnus-cite-attribution-postfix
(point-max) t
)
378 (let* ((start (match-beginning 0))
380 (wrote (count-lines (point-min) end
))
381 (prefix (gnus-cite-find-prefix wrote
))
382 ;; Check previous line for an attribution leader.
384 (beginning-of-line 1)
385 (and (looking-at gnus-supercite-secondary-regexp
)
386 (buffer-substring (match-beginning 1)
390 (and (re-search-backward gnus-cite-attribution-prefix
392 (beginning-of-line 0)
395 (not (re-search-forward gnus-cite-attribution-postfix
397 (count-lines (point-min) (1+ (point)))))))
401 (setq gnus-cite-loose-attribution-alist
402 (cons (list wrote in prefix tag
)
403 gnus-cite-loose-attribution-alist
))))
404 ;; Find exact supercite citations.
405 (gnus-cite-match-attributions 'small nil
409 (regexp-quote prefix
) "[ \t]*"
410 (regexp-quote tag
) ">"))))
411 ;; Find loose supercite citations after attributions.
412 (gnus-cite-match-attributions 'small t
414 (if tag
(concat "\\<"
417 ;; Find loose supercite citations anywhere.
418 (gnus-cite-match-attributions 'small nil
420 (if tag
(concat "\\<"
423 ;; Find nested citations after attributions.
424 (gnus-cite-match-attributions 'small-if-unique t
426 (concat "\\`" (regexp-quote prefix
) ".+")))
427 ;; Find nested citations anywhere.
428 (gnus-cite-match-attributions 'small nil
430 (concat "\\`" (regexp-quote prefix
) ".+")))
431 ;; Remove loose prefixes with too few lines.
432 (let ((alist gnus-cite-loose-prefix-alist
)
435 (setq entry
(car alist
)
437 (if (< (length (cdr entry
)) gnus-cite-minimum-match-count
)
438 (setq gnus-cite-prefix-alist
439 (delq entry gnus-cite-prefix-alist
)
440 gnus-cite-loose-prefix-alist
441 (delq entry gnus-cite-loose-prefix-alist
)))))
442 ;; Find flat attributions.
443 (gnus-cite-match-attributions 'first t nil
)
444 ;; Find any attributions (are we getting desperate yet?).
445 (gnus-cite-match-attributions 'first nil nil
))
447 (defun gnus-cite-match-attributions (sort after fun
)
448 ;; Match all loose attributions and citations (SORT AFTER FUN) .
450 ;; If SORT is `small', the citation with the shortest prefix will be
451 ;; used, if it is `first' the first prefix will be used, if it is
452 ;; `small-if-unique' the shortest prefix will be used if the
453 ;; attribution line does not share its own prefix with other
454 ;; loose attribution lines, otherwise the first prefix will be used.
456 ;; If AFTER is non-nil, only citations after the attribution line
457 ;; will be considered.
459 ;; If FUN is non-nil, it will be called with the arguments (WROTE
460 ;; PREFIX TAG) and expected to return a regular expression. Only
461 ;; citations whose prefix matches the regular expression will be
464 ;; WROTE is the attribution line number.
465 ;; PREFIX is the attribution line prefix.
466 ;; TAG is the SuperCite tag on the attribution line.
467 (let ((atts gnus-cite-loose-attribution-alist
)
469 att wrote in prefix tag regexp limit smallest best size
)
477 regexp
(if fun
(funcall fun prefix tag
) "")
478 size
(cond ((eq sort
'small
) t
)
479 ((eq sort
'first
) nil
)
480 (t (< (length (gnus-cite-find-loose prefix
)) 2)))
481 limit
(if after wrote -
1)
484 (let ((cites gnus-cite-loose-prefix-alist
)
485 cite candidate numbers first compare
)
487 (setq cite
(car cites
)
491 first
(apply 'min numbers
)
492 compare
(if size
(length candidate
) first
))
495 (string-match regexp candidate
)
501 (setq gnus-cite-loose-attribution-alist
502 (delq att gnus-cite-loose-attribution-alist
))
503 (setq gnus-cite-attribution-alist
504 (cons (cons wrote
(car best
)) gnus-cite-attribution-alist
))
506 (setq gnus-cite-attribution-alist
507 (cons (cons in
(car best
)) gnus-cite-attribution-alist
)))
508 (if (memq best gnus-cite-loose-prefix-alist
)
509 (let ((loop gnus-cite-prefix-alist
)
512 (setq gnus-cite-loose-prefix-alist
513 (delq best gnus-cite-loose-prefix-alist
))
515 (setq current
(car loop
)
517 (if (eq current best
)
519 (setcdr current
(gnus-set-difference (cdr current
) numbers
))
520 (if (null (cdr current
))
521 (setq gnus-cite-loose-prefix-alist
522 (delq current gnus-cite-loose-prefix-alist
)
523 atts
(delq current atts
)))))))))))
525 (defun gnus-cite-find-loose (prefix)
526 ;; Return a list of loose attribution lines prefixed by PREFIX.
527 (let* ((atts gnus-cite-loose-attribution-alist
)
533 (if (string-equal (gnus-cite-find-prefix line
) prefix
)
534 (setq lines
(cons line lines
))))
537 (defun gnus-cite-add-face (number prefix face
)
538 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
540 (let ((inhibit-point-motion-hooks t
)
543 (forward-char (length prefix
))
544 (skip-chars-forward " \t")
547 (skip-chars-backward " \t")
550 (gnus-overlay-put (gnus-make-overlay from to
) 'face face
)))))
552 (defun gnus-cite-toggle (prefix)
554 (set-buffer gnus-article-buffer
)
555 (let ((buffer-read-only nil
)
556 (numbers (cdr (assoc prefix gnus-cite-prefix-alist
)))
557 (inhibit-point-motion-hooks t
)
560 (setq number
(car numbers
)
561 numbers
(cdr numbers
))
563 (cond ((get-text-property (point) 'invisible
)
564 (remove-text-properties (point) (progn (forward-line 1) (point))
565 gnus-hidden-properties
))
566 ((assq number gnus-cite-attribution-alist
))
568 (add-text-properties (point) (progn (forward-line 1) (point))
569 gnus-hidden-properties
)))))))
571 (defun gnus-cite-find-prefix (line)
572 ;; Return citation prefix for LINE.
573 (let ((alist gnus-cite-prefix-alist
)
577 (setq entry
(car alist
)
579 (if (memq line
(cdr entry
))
580 (setq prefix
(car entry
))))
587 ;;; gnus-cite.el ends here