1 ;;; gnus-cite.el --- parse citations in articles for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
4 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
5 ;; Keywords: news, mail
7 ;; This file is part of GNU Emacs.
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)
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.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
32 (autoload 'gnus-article-add-button
"gnus-vis")
37 (defvar gnus-cite-parse-max-size
25000
38 "Maximum article size (in bytes) where parsing citations is allowed.
39 Set it to nil to parse all articles.")
41 (defvar gnus-cite-prefix-regexp
42 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
43 "Regexp matching the longest possible citation prefix on a line.")
45 (defvar gnus-cite-max-prefix
20
46 "Maximal possible length for a citation prefix.")
48 (defvar gnus-supercite-regexp
49 (concat "^\\(" gnus-cite-prefix-regexp
"\\)? *"
50 ">>>>> +\"\\([^\"\n]+\\)\" +==")
51 "Regexp matching normal SuperCite attribution lines.
52 The first regexp group should match a prefix added by another package.")
54 (defvar gnus-supercite-secondary-regexp
"^.*\"\\([^\"\n]+\\)\" +=="
55 "Regexp matching mangled SuperCite attribution lines.
56 The first regexp group should match the SuperCite attribution.")
58 (defvar gnus-cite-minimum-match-count
2
59 "Minimal number of identical prefix'es before we believe it is a citation.")
62 ;(defvar gnus-cite-face-list
63 ; (if (eq gnus-display-type 'color)
64 ; (if (eq gnus-background-mode 'dark) 'light 'dark)
66 ; "Faces used for displaying different citations.
67 ;It is either a list of face names, or one of the following special
70 ;dark: Create faces from `gnus-face-dark-name-list'.
71 ;light: Create faces from `gnus-face-light-name-list'.
73 ;The variable `gnus-make-foreground' determines whether the created
74 ;faces change the foreground or the background colors.")
76 (defvar gnus-cite-attribution-prefix
"in article\\|in <"
77 "Regexp matching the beginning of an attribution line.")
79 (defvar gnus-cite-attribution-postfix
80 "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
81 "Regexp matching the end of an attribution line.
82 The text matching the first grouping will be used as a button.")
85 ;(defvar gnus-cite-attribution-face 'underline
86 ; "Face used for attribution lines.
87 ;It is merged with the face for the cited text belonging to the attribution.")
90 ;(defvar gnus-cite-hide-percentage 50
91 ; "Only hide cited text if it is larger than this percent of the body.")
94 ;(defvar gnus-cite-hide-absolute 10
95 ; "Only hide cited text if there is at least this number of cited lines.")
98 ;(defvar gnus-face-light-name-list
99 ; '("light blue" "light cyan" "light yellow" "light pink"
100 ; "pale green" "beige" "orange" "magenta" "violet" "medium purple"
102 ; "Names of light colors.")
105 ;(defvar gnus-face-dark-name-list
106 ; '("dark salmon" "firebrick"
107 ; "dark green" "dark orange" "dark khaki" "dark violet"
109 ; "Names of dark colors.")
111 ;;; Internal Variables:
113 (defvar gnus-article-length nil
)
114 ;; Length of article last time we parsed it.
115 ;; BUG! KLUDGE! UGLY! FIX ME!
117 (defvar gnus-cite-prefix-alist nil
)
118 ;; Alist of citation prefixes.
119 ;; The cdr is a list of lines with that prefix.
121 (defvar gnus-cite-attribution-alist nil
)
122 ;; Alist of attribution lines.
123 ;; The car is a line number.
124 ;; The cdr is the prefix for the citation started by that line.
126 (defvar gnus-cite-loose-prefix-alist nil
)
127 ;; Alist of citation prefixes that have no matching attribution.
128 ;; The cdr is a list of lines with that prefix.
130 (defvar gnus-cite-loose-attribution-alist nil
)
131 ;; Alist of attribution lines that have no matching citation.
132 ;; Each member has the form (WROTE IN PREFIX TAG), where
133 ;; WROTE: is the attribution line number
134 ;; IN: is the line number of the previous line if part of the same attribution,
135 ;; PREFIX: Is the citation prefix of the attribution line(s), and
136 ;; TAG: Is a SuperCite tag, if any.
140 (defun gnus-article-highlight-citation (&optional force
)
141 "Highlight cited text.
142 Each citation in the article will be highlighted with a different face.
143 The faces are taken from `gnus-cite-face-list'.
144 Attribution lines are highlighted with the same face as the
145 corresponding citation merged with `gnus-cite-attribution-face'.
147 Text is considered cited if at least `gnus-cite-minimum-match-count'
148 lines matches `gnus-cite-prefix-regexp' with the same prefix.
150 Lines matching `gnus-cite-attribution-postfix' and perhaps
151 `gnus-cite-attribution-prefix' are considered attribution lines."
152 (interactive (list 'force
))
153 ;; Create dark or light faces if necessary.
154 (cond ((eq gnus-cite-face-list
'light
)
155 (setq gnus-cite-face-list
156 (mapcar 'gnus-make-face gnus-face-light-name-list
)))
157 ((eq gnus-cite-face-list
'dark
)
158 (setq gnus-cite-face-list
159 (mapcar 'gnus-make-face gnus-face-dark-name-list
))))
161 (set-buffer gnus-article-buffer
)
162 (gnus-cite-parse-maybe force
)
163 (let ((buffer-read-only nil
)
164 (alist gnus-cite-prefix-alist
)
165 (faces gnus-cite-face-list
)
166 (inhibit-point-motion-hooks t
)
167 face entry prefix skip numbers number face-alist
)
168 ;; Loop through citation prefixes.
170 (setq entry
(car alist
)
175 faces
(or (cdr faces
) gnus-cite-face-list
)
176 face-alist
(cons (cons prefix face
) face-alist
))
178 (setq number
(car numbers
)
179 numbers
(cdr numbers
))
180 (and (not (assq number gnus-cite-attribution-alist
))
181 (not (assq number gnus-cite-loose-attribution-alist
))
182 (gnus-cite-add-face number prefix face
))))
183 ;; Loop through attribution lines.
184 (setq alist gnus-cite-attribution-alist
)
186 (setq entry
(car alist
)
190 skip
(gnus-cite-find-prefix number
)
191 face
(cdr (assoc prefix face-alist
)))
192 ;; Add attribution button.
194 (if (re-search-forward gnus-cite-attribution-postfix
195 (save-excursion (end-of-line 1) (point))
197 (gnus-article-add-button (match-beginning 1) (match-end 1)
198 'gnus-cite-toggle prefix
))
199 ;; Highlight attribution line.
200 (gnus-cite-add-face number skip face
)
201 (gnus-cite-add-face number skip gnus-cite-attribution-face
))
202 ;; Loop through attribution lines.
203 (setq alist gnus-cite-loose-attribution-alist
)
205 (setq entry
(car alist
)
208 skip
(gnus-cite-find-prefix number
))
209 (gnus-cite-add-face number skip gnus-cite-attribution-face
)))))
211 (defun gnus-article-hide-citation (&optional force
)
212 "Hide all cited text except attribution lines.
213 See the documentation for `gnus-article-highlight-citation'."
214 (interactive (list 'force
))
216 (set-buffer gnus-article-buffer
)
217 (gnus-cite-parse-maybe force
)
218 (let ((buffer-read-only nil
)
219 (alist gnus-cite-prefix-alist
)
220 (inhibit-point-motion-hooks t
)
223 (setq numbers
(cdr (car alist
))
226 (setq number
(car numbers
)
227 numbers
(cdr numbers
))
229 (or (assq number gnus-cite-attribution-alist
)
230 (add-text-properties (point) (progn (forward-line 1) (point))
231 gnus-hidden-properties
)))))))
233 (defun gnus-article-hide-citation-maybe (&optional force
)
234 "Hide cited text that has an attribution line.
235 This will do nothing unless at least `gnus-cite-hide-percentage'
236 percent and at least `gnus-cite-hide-absolute' lines of the body is
237 cited text with attributions. When called interactively, these two
238 variables are ignored.
239 See also the documentation for `gnus-article-highlight-citation'."
240 (interactive (list 'force
))
242 (set-buffer gnus-article-buffer
)
243 (gnus-cite-parse-maybe force
)
244 (goto-char (point-min))
245 (search-forward "\n\n" nil t
)
246 (let ((start (point))
247 (atts gnus-cite-attribution-alist
)
248 (buffer-read-only nil
)
249 (inhibit-point-motion-hooks t
)
252 (goto-char (point-max))
253 (re-search-backward gnus-signature-separator nil t
)
254 (setq total
(count-lines start
(point)))
256 (setq hiden
(+ hiden
(length (cdr (assoc (cdr (car atts
))
257 gnus-cite-prefix-alist
))))
260 (and (> (* 100 hiden
) (* gnus-cite-hide-percentage total
))
261 (> hiden gnus-cite-hide-absolute
)))
263 (setq atts gnus-cite-attribution-alist
)
265 (setq total
(cdr (assoc (cdr (car atts
)) gnus-cite-prefix-alist
))
268 (setq hiden
(car total
)
271 (or (assq hiden gnus-cite-attribution-alist
)
272 (add-text-properties (point)
273 (progn (forward-line 1) (point))
274 gnus-hidden-properties
)))))))))
276 ;;; Internal functions:
278 (defun gnus-cite-parse-maybe (&optional force
)
279 ;; Parse if the buffer has changes since last time.
280 (if (eq gnus-article-length
(- (point-max) (point-min)))
282 ;;Reset parser information.
283 (setq gnus-cite-prefix-alist nil
284 gnus-cite-attribution-alist nil
285 gnus-cite-loose-prefix-alist nil
286 gnus-cite-loose-attribution-alist nil
)
287 ;; Parse if not too large.
289 gnus-cite-parse-max-size
290 (> (buffer-size) gnus-cite-parse-max-size
))
292 (setq gnus-article-length
(- (point-max) (point-min)))
295 (defun gnus-cite-parse ()
296 ;; Parse and connect citation prefixes and attribution lines.
298 ;; Parse current buffer searching for citation prefixes.
299 (goto-char (point-min))
300 (or (search-forward "\n\n" nil t
)
301 (goto-char (point-max)))
302 (let ((line (1+ (count-lines (point-min) (point))))
305 (goto-char (point-max))
306 (re-search-backward gnus-signature-separator nil t
)
308 alist entry start begin end numbers prefix
)
309 ;; Get all potential prefixes in `alist'.
310 (while (< (point) max
)
313 end
(progn (beginning-of-line 2) (point))
316 ;; Ignore standard SuperCite attribution prefix.
317 (if (looking-at gnus-supercite-regexp
)
319 (setq end
(1+ (match-end 1)))
320 (setq end
(1+ begin
))))
321 ;; Ignore very long prefixes.
322 (if (> end
(+ (point) gnus-cite-max-prefix
))
323 (setq end
(+ (point) gnus-cite-max-prefix
)))
324 (while (re-search-forward gnus-cite-prefix-regexp
(1- end
) t
)
326 (setq end
(match-end 0)
327 prefix
(buffer-substring begin end
))
328 (set-text-properties 0 (length prefix
) nil prefix
)
329 (setq entry
(assoc prefix alist
))
331 (setcdr entry
(cons line
(cdr entry
)))
332 (setq alist
(cons (list prefix line
) alist
)))
335 (setq line
(1+ line
)))
336 ;; We got all the potential prefixes. Now create
337 ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
338 ;; line that appears at least gnus-cite-minimum-match-count
339 ;; times. First sort them by length. Longer is older.
340 (setq alist
(sort alist
(lambda (a b
)
341 (> (length (car a
)) (length (car b
))))))
343 (setq entry
(car alist
)
347 (cond ((null numbers
)
348 ;; No lines with this prefix that wasn't also part of
351 ((< (length numbers
) gnus-cite-minimum-match-count
)
352 ;; Too few lines with this prefix. We keep it a bit
353 ;; longer in case it is an exact match for an attribution
354 ;; line, but we don't remove the line from other
356 (setq gnus-cite-prefix-alist
357 (cons entry gnus-cite-prefix-alist
)))
359 (setq gnus-cite-prefix-alist
(cons entry
360 gnus-cite-prefix-alist
))
361 ;; Remove articles from other prefixes.
365 (setq current
(car loop
)
368 (gnus-set-difference (cdr current
) numbers
))))))))
369 ;; No citations have been connected to attribution lines yet.
370 (setq gnus-cite-loose-prefix-alist
(append gnus-cite-prefix-alist nil
))
372 ;; Parse current buffer searching for attribution lines.
373 (goto-char (point-min))
374 (search-forward "\n\n" nil t
)
375 (while (re-search-forward gnus-cite-attribution-postfix
(point-max) t
)
376 (let* ((start (match-beginning 0))
378 (wrote (count-lines (point-min) end
))
379 (prefix (gnus-cite-find-prefix wrote
))
380 ;; Check previous line for an attribution leader.
382 (beginning-of-line 1)
383 (and (looking-at gnus-supercite-secondary-regexp
)
384 (buffer-substring (match-beginning 1)
388 (and (re-search-backward gnus-cite-attribution-prefix
390 (beginning-of-line 0)
393 (not (re-search-forward gnus-cite-attribution-postfix
395 (count-lines (point-min) (1+ (point)))))))
399 (setq gnus-cite-loose-attribution-alist
400 (cons (list wrote in prefix tag
)
401 gnus-cite-loose-attribution-alist
))))
402 ;; Find exact supercite citations.
403 (gnus-cite-match-attributions 'small nil
407 (regexp-quote prefix
) "[ \t]*"
408 (regexp-quote tag
) ">"))))
409 ;; Find loose supercite citations after attributions.
410 (gnus-cite-match-attributions 'small t
412 (if tag
(concat "\\<"
415 ;; Find loose supercite citations anywhere.
416 (gnus-cite-match-attributions 'small nil
418 (if tag
(concat "\\<"
421 ;; Find nested citations after attributions.
422 (gnus-cite-match-attributions 'small-if-unique t
424 (concat "\\`" (regexp-quote prefix
) ".+")))
425 ;; Find nested citations anywhere.
426 (gnus-cite-match-attributions 'small nil
428 (concat "\\`" (regexp-quote prefix
) ".+")))
429 ;; Remove loose prefixes with too few lines.
430 (let ((alist gnus-cite-loose-prefix-alist
)
433 (setq entry
(car alist
)
435 (if (< (length (cdr entry
)) gnus-cite-minimum-match-count
)
436 (setq gnus-cite-prefix-alist
437 (delq entry gnus-cite-prefix-alist
)
438 gnus-cite-loose-prefix-alist
439 (delq entry gnus-cite-loose-prefix-alist
)))))
440 ;; Find flat attributions.
441 (gnus-cite-match-attributions 'first t nil
)
442 ;; Find any attributions (are we getting desperate yet?).
443 (gnus-cite-match-attributions 'first nil nil
))
445 (defun gnus-cite-match-attributions (sort after fun
)
446 ;; Match all loose attributions and citations (SORT AFTER FUN) .
448 ;; If SORT is `small', the citation with the shortest prefix will be
449 ;; used, if it is `first' the first prefix will be used, if it is
450 ;; `small-if-unique' the shortest prefix will be used if the
451 ;; attribution line does not share its own prefix with other
452 ;; loose attribution lines, otherwise the first prefix will be used.
454 ;; If AFTER is non-nil, only citations after the attribution line
455 ;; will be concidered.
457 ;; If FUN is non-nil, it will be called with the arguments (WROTE
458 ;; PREFIX TAG) and expected to return a regular expression. Only
459 ;; citations whose prefix matches the regular expression will be
462 ;; WROTE is the attribution line number.
463 ;; PREFIX is the attribution line prefix.
464 ;; TAG is the SuperCite tag on the attribution line.
465 (let ((atts gnus-cite-loose-attribution-alist
)
467 att wrote in prefix tag regexp limit smallest best size
)
475 regexp
(if fun
(funcall fun prefix tag
) "")
476 size
(cond ((eq sort
'small
) t
)
477 ((eq sort
'first
) nil
)
478 (t (< (length (gnus-cite-find-loose prefix
)) 2)))
479 limit
(if after wrote -
1)
482 (let ((cites gnus-cite-loose-prefix-alist
)
483 cite candidate numbers first compare
)
485 (setq cite
(car cites
)
489 first
(apply 'min numbers
)
490 compare
(if size
(length candidate
) first
))
493 (string-match regexp candidate
)
499 (setq gnus-cite-loose-attribution-alist
500 (delq att gnus-cite-loose-attribution-alist
))
501 (setq gnus-cite-attribution-alist
502 (cons (cons wrote
(car best
)) gnus-cite-attribution-alist
))
504 (setq gnus-cite-attribution-alist
505 (cons (cons in
(car best
)) gnus-cite-attribution-alist
)))
506 (if (memq best gnus-cite-loose-prefix-alist
)
507 (let ((loop gnus-cite-prefix-alist
)
510 (setq gnus-cite-loose-prefix-alist
511 (delq best gnus-cite-loose-prefix-alist
))
513 (setq current
(car loop
)
515 (if (eq current best
)
517 (setcdr current
(gnus-set-difference (cdr current
) numbers
))
518 (if (null (cdr current
))
519 (setq gnus-cite-loose-prefix-alist
520 (delq current gnus-cite-loose-prefix-alist
)
521 atts
(delq current atts
)))))))))))
523 (defun gnus-cite-find-loose (prefix)
524 ;; Return a list of loose attribution lines prefixed by PREFIX.
525 (let* ((atts gnus-cite-loose-attribution-alist
)
531 (if (string-equal (gnus-cite-find-prefix line
) prefix
)
532 (setq lines
(cons line lines
))))
535 (defun gnus-cite-add-face (number prefix face
)
536 ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
538 (let ((inhibit-point-motion-hooks t
)
541 (forward-char (length prefix
))
542 (skip-chars-forward " \t")
545 (skip-chars-backward " \t")
548 (gnus-overlay-put (gnus-make-overlay from to
) 'face face
)))))
550 (defun gnus-cite-toggle (prefix)
552 (set-buffer gnus-article-buffer
)
553 (let ((buffer-read-only nil
)
554 (numbers (cdr (assoc prefix gnus-cite-prefix-alist
)))
555 (inhibit-point-motion-hooks t
)
558 (setq number
(car numbers
)
559 numbers
(cdr numbers
))
561 (cond ((get-text-property (point) 'invisible
)
562 (remove-text-properties (point) (progn (forward-line 1) (point))
563 gnus-hidden-properties
))
564 ((assq number gnus-cite-attribution-alist
))
566 (add-text-properties (point) (progn (forward-line 1) (point))
567 gnus-hidden-properties
)))))))
569 (defun gnus-cite-find-prefix (line)
570 ;; Return citation prefix for LINE.
571 (let ((alist gnus-cite-prefix-alist
)
575 (setq entry
(car alist
)
577 (if (memq line
(cdr entry
))
578 (setq prefix
(car entry
))))
585 ;;; gnus-cite.el ends here