cgit.sxemacs.org Git - gnus/blob - lisp/gnus-cite.el

   1 ;;; gnus-cite.el --- parse citations in articles for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   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
  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.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'gnus)
  28 (require 'gnus-msg)
  29
  30 (eval-and-compile
  31   (autoload 'gnus-article-add-button "gnus-vis")
  32   )
  33
  34 ;;; Customization:
  35
  36 (defvar gnus-cite-prefix-regexp
  37     "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
  38   "Regexp matching the longest possible citation prefix on a line.")
  39
  40 (defvar gnus-cite-max-prefix 20
  41   "Maximal possible length for a citation prefix.")
  42
  43 (defvar gnus-supercite-regexp
  44   (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
  45           ">>>>> +\"\\([^\"\n]+\\)\" +==")
  46   "Regexp matching normal SuperCite attribution lines.
  47 The first regexp group should match a prefix added by another package.")
  48
  49 (defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
  50   "Regexp matching mangled SuperCite attribution lines.
  51 The first regexp group should match the SuperCite attribution.")
  52
  53 (defvar gnus-cite-minimum-match-count 2
  54   "Minimal number of identical prefix'es before we believe it is a citation.")
  55
  56 (defvar gnus-cite-face-list
  57   (if (eq gnus-display-type 'color)
  58       (if (eq gnus-background-mode 'dark) 'light 'dark)
  59     '(italic))
  60   "Faces used for displaying different citations.
  61 It is either a list of face names, or one of the following special
  62 values:
  63
  64 dark: Create faces from `gnus-face-dark-name-list'.
  65 light: Create faces from `gnus-face-light-name-list'.
  66
  67 The variable `gnus-make-foreground' determines whether the created
  68 faces change the foreground or the background colors.")
  69
  70 (defvar gnus-cite-attribution-prefix "in article\\|in <"
  71   "Regexp matching the beginning of an attribution line.")
  72
  73 (defvar gnus-cite-attribution-postfix
  74   "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
  75   "Regexp matching the end of an attribution line.
  76 The text matching the first grouping will be used as a button.")
  77
  78 (defvar gnus-cite-attribution-face 'underline
  79   "Face used for attribution lines.
  80 It is merged with the face for the cited text belonging to the attribution.")
  81
  82 (defvar gnus-cite-hide-percentage 50
  83   "Only hide cited text if it is larger than this percent of the body.")
  84
  85 (defvar gnus-cite-hide-absolute 10
  86   "Only hide cited text if there is at least this number of cited lines.")
  87
  88 (defvar gnus-face-light-name-list
  89   '("light blue" "light cyan" "light yellow" "light pink"
  90     "pale green" "beige" "orange" "magenta" "violet" "medium purple"
  91     "turquoise")
  92   "Names of light colors.")
  93
  94 (defvar gnus-face-dark-name-list
  95   '("violetred3" "violetred2" "violetred1" "violetred3" "deepskyblue3" "deepskyblue2" "deepskyblue1" "deepskyblue"
  96     "dark salmon" "firebrick"
  97     "dark green" "dark orange" "dark khaki" "dark violet"
  98     "dark turquoise")
  99   "Names of dark colors.")
 100
 101 ;;; Internal Variables:
 102
 103 (defvar gnus-article-length nil)
 104 ;; Length of article last time we parsed it.
 105
 106 (defvar gnus-cite-prefix-alist nil)
 107 ;; Alist of citation prefixes.
 108 ;; The cdr is a list of lines with that prefix.
 109
 110 (defvar gnus-cite-attribution-alist nil)
 111 ;; Alist of attribution lines.
 112 ;; The car is a line number.
 113 ;; The cdr is the prefix for the citation started by that line.
 114
 115 (defvar gnus-cite-loose-prefix-alist nil)
 116 ;; Alist of citation prefixes that have no matching attribution.
 117 ;; The cdr is a list of lines with that prefix.
 118
 119 (defvar gnus-cite-loose-attribution-alist nil)
 120 ;; Alist of attribution lines that have no matching citation.
 121 ;; Each member has the form (WROTE IN PREFIX TAG), where
 122 ;; WROTE: is the attribution line number
 123 ;; IN: is the line number of the previous line if part of the same attribution,
 124 ;; PREFIX: Is the citation prefix of the attribution line(s), and
 125 ;; TAG: Is a SuperCite tag, if any.
 126
 127 ;;; Commands:
 128
 129 (defun gnus-article-highlight-citation ()
 130   "Highlight cited text.
 131 Each citation in the article will be highlighted with a different face.
 132 The faces are taken from `gnus-cite-face-list'.
 133 Attribution lines are highlighted with the sameface as the
 134 corresponding citation merged with `gnus-cite-attribution-face'.
 135
 136 Text is considered cited if at least `gnus-cite-minimum-match-count'
 137 lines matches `gnus-cite-prefix-regexp' with the same prefix.
 138
 139 Lines matching `gnus-cite-attribution-postfix' and perhaps
 140 `gnus-cite-attribution-prefix' are considered attribution lines."
 141   (interactive)
 142   ;; Create dark or light faces if necessary.
 143   (cond ((eq gnus-cite-face-list 'light)
 144          (setq gnus-cite-face-list
 145              (mapcar 'gnus-make-face gnus-face-light-name-list)))
 146         ((eq gnus-cite-face-list 'dark)
 147          (setq gnus-cite-face-list
 148              (mapcar 'gnus-make-face gnus-face-dark-name-list))))
 149   (save-excursion
 150     (set-buffer gnus-article-buffer)
 151     (gnus-cite-parse-maybe)
 152     (let ((buffer-read-only nil)
 153           (alist gnus-cite-prefix-alist)
 154           (faces gnus-cite-face-list)
 155           (inhibit-point-motion-hooks t)
 156           face entry prefix skip numbers number face-alist)
 157       ;; Loop through citation prefixes.
 158       (while alist
 159         (setq entry (car alist)
 160               alist (cdr alist)
 161               prefix (car entry)
 162               numbers (cdr entry)
 163               face (car faces)
 164               faces (or (cdr faces) gnus-cite-face-list)
 165               face-alist (cons (cons prefix face) face-alist))
 166         (while numbers
 167           (setq number (car numbers)
 168                 numbers (cdr numbers))
 169           (and (not (assq number gnus-cite-attribution-alist))
 170                (not (assq number gnus-cite-loose-attribution-alist))
 171                (gnus-cite-add-face number prefix face))))
 172       ;; Loop through attribution lines.
 173       (setq alist gnus-cite-attribution-alist)
 174       (while alist
 175         (setq entry (car alist)
 176               alist (cdr alist)
 177               number (car entry)
 178               prefix (cdr entry)
 179               skip (gnus-cite-find-prefix number)
 180               face (cdr (assoc prefix face-alist)))
 181         ;; Add attribution button.
 182         (goto-line number)
 183         (if (re-search-forward gnus-cite-attribution-postfix
 184                                (save-excursion (end-of-line 1) (point))
 185                                t)
 186             (gnus-article-add-button (match-beginning 1) (match-end 1)
 187                                      'gnus-cite-toggle prefix))
 188         ;; Highlight attribution line.
 189         (gnus-cite-add-face number skip face)
 190         (gnus-cite-add-face number skip gnus-cite-attribution-face))
 191       ;; Loop through attribution lines.
 192       (setq alist gnus-cite-loose-attribution-alist)
 193       (while alist
 194         (setq entry (car alist)
 195               alist (cdr alist)
 196               number (car entry)
 197               skip (gnus-cite-find-prefix number))
 198         (gnus-cite-add-face number skip gnus-cite-attribution-face)))))
 199
 200 (defun gnus-article-hide-citation ()
 201   "Hide all cited text except attribution lines.
 202 See the documentation for `gnus-article-highlight-citation'."
 203   (interactive)
 204   (save-excursion
 205     (set-buffer gnus-article-buffer)
 206     (gnus-cite-parse-maybe)
 207     (let ((buffer-read-only nil)
 208           (alist gnus-cite-prefix-alist)
 209           (inhibit-point-motion-hooks t)
 210           numbers number)
 211       (while alist
 212         (setq numbers (cdr (car alist))
 213               alist (cdr alist))
 214         (while numbers
 215           (setq number (car numbers)
 216                 numbers (cdr numbers))
 217           (goto-line number)
 218           (or (assq number gnus-cite-attribution-alist)
 219               (add-text-properties (point) (progn (forward-line 1) (point))
 220                                    gnus-hidden-properties)))))))
 221
 222 (defun gnus-article-hide-citation-maybe (&optional force)
 223   "Hide cited text that has an attribution line.
 224 This will do nothing unless at least `gnus-cite-hide-percentage'
 225 percent ans at least `gnus-cite-hide-absolute' lines of the body is
 226 cited text with attributions.  When called interactively, these two
 227 variables are ignored.
 228 See also the documentation for `gnus-article-highlight-citation'."
 229   (interactive (list 'force))
 230   (save-excursion
 231     (set-buffer gnus-article-buffer)
 232     (gnus-cite-parse-maybe)
 233     (goto-char (point-min))
 234     (search-forward "\n\n")
 235     (let ((start (point))
 236           (atts gnus-cite-attribution-alist)
 237           (buffer-read-only nil)
 238           (inhibit-point-motion-hooks t)
 239           (hiden 0)
 240           total)
 241       (goto-char (point-max))
 242       (re-search-backward gnus-signature-separator nil t)
 243       (setq total (count-lines start (point)))
 244       (while atts
 245         (setq hiden (+ hiden (length (cdr (assoc (cdr (car atts))
 246                                                  gnus-cite-prefix-alist))))
 247               atts (cdr atts)))
 248       (if (or force
 249               (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
 250                    (> hiden gnus-cite-hide-absolute)))
 251           (progn
 252             (setq atts gnus-cite-attribution-alist)
 253             (while atts
 254               (setq total (cdr (assoc (cdr (car atts)) gnus-cite-prefix-alist))
 255                     atts (cdr atts))
 256               (while total
 257                 (setq hiden (car total)
 258                       total (cdr total))
 259                 (goto-line hiden)
 260                 (or (assq hiden gnus-cite-attribution-alist)
 261                     (add-text-properties (point)
 262                                          (progn (forward-line 1) (point))
 263                                          gnus-hidden-properties)))))))))
 264
 265 ;;; Internal functions:
 266
 267 (defun gnus-cite-parse-maybe ()
 268   ;; Parse if the buffer has changes since last time.
 269   (if (eq gnus-article-length (- (point-max) (point-min)))
 270       ()
 271     (setq gnus-article-length (- (point-max) (point-min)))
 272     (gnus-cite-parse)))
 273
 274 (defun gnus-cite-parse ()
 275   ;; Parse and connect citation prefixes and attribution lines.
 276   (setq gnus-cite-prefix-alist nil
 277         gnus-cite-attribution-alist nil
 278         gnus-cite-loose-prefix-alist nil
 279         gnus-cite-loose-attribution-alist nil)
 280   ;; Parse current buffer searching for citation prefixes.
 281   (goto-char (point-min))
 282   (search-forward "\n\n")
 283   (let ((line (1+ (count-lines (point-min) (point))))
 284         (case-fold-search t)
 285         (max (save-excursion
 286                (goto-char (point-max))
 287                (re-search-backward gnus-signature-separator nil t)
 288                (point)))
 289         alist entry start begin end numbers prefix)
 290     ;; Get all potential prefixes in `alist'.
 291     (while (< (point) max)
 292       ;; Each line.
 293       (setq begin (point)
 294             end (progn (beginning-of-line 2) (point))
 295             start end)
 296       (goto-char begin)
 297       ;; Ignore standard SuperCite attribution prefix.
 298       (if (looking-at gnus-supercite-regexp)
 299           (if (match-end 1)
 300               (setq end (1+ (match-end 1)))
 301             (setq end (1+ begin))))
 302       ;; Ignore very long prefixes.
 303       (if (> end (+ (point) gnus-cite-max-prefix))
 304           (setq end (+ (point) gnus-cite-max-prefix)))
 305       (while (re-search-forward gnus-cite-prefix-regexp (1- end) t)
 306         ;; Each prefix.
 307         (setq end (match-end 0)
 308               prefix (buffer-substring begin end))
 309         (set-text-properties 0 (length prefix) nil prefix)
 310         (setq entry (assoc prefix alist))
 311         (if entry
 312             (setcdr entry (cons line (cdr entry)))
 313           (setq alist (cons (list prefix line) alist)))
 314         (goto-char begin))
 315       (goto-char start)
 316       (setq line (1+ line)))
 317     ;; We got all the potential prefixes.  Now create
 318     ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
 319     ;; line that appears at least gnus-cite-minimum-match-count
 320     ;; times. First sort them by length.  Longer is older.
 321     (setq alist (sort alist (lambda (a b)
 322                               (> (length (car a)) (length (car b))))))
 323     (while alist
 324       (setq entry (car alist)
 325             prefix (car entry)
 326             numbers (cdr entry)
 327             alist (cdr alist))
 328       (cond ((null numbers)
 329              ;; No lines with this prefix that wasn't also part of
 330              ;; a longer prefix.
 331              )
 332             ((< (length numbers) gnus-cite-minimum-match-count)
 333              ;; Too few lines with this prefix.  We keep it a bit
 334              ;; longer in case it is an exact match for an attribution
 335              ;; line, but we don't remove the line from other
 336              ;; prefixes.
 337              (setq gnus-cite-prefix-alist
 338                    (cons entry gnus-cite-prefix-alist)))
 339             (t
 340              (setq gnus-cite-prefix-alist (cons entry gnus-cite-prefix-alist))
 341              ;; Remove articles from other prefixes.
 342              (let ((loop alist)
 343                    current)
 344                (while loop
 345                  (setq current (car loop)
 346                        loop (cdr loop))
 347                  (setcdr current
 348                          (gnus-set-difference (cdr current) numbers))))))))
 349   ;; No citations have been connected to attribution lines yet.
 350   (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil))
 351
 352   ;; Parse current buffer searching for attribution lines.
 353   (goto-char (point-min))
 354   (search-forward "\n\n")
 355   (while (re-search-forward gnus-cite-attribution-postfix (point-max) t)
 356     (let* ((start (match-beginning 0))
 357            (end (match-end 0))
 358            (wrote (count-lines (point-min) end))
 359            (prefix (gnus-cite-find-prefix wrote))
 360            ;; Check previous line for an attribution leader.
 361            (tag (progn
 362                   (beginning-of-line 1)
 363                   (and (looking-at gnus-supercite-secondary-regexp)
 364                        (buffer-substring (match-beginning 1)
 365                                          (match-end 1)))))
 366            (in (progn
 367                  (goto-char start)
 368                  (and (re-search-backward gnus-cite-attribution-prefix
 369                                           (save-excursion
 370                                             (beginning-of-line 0)
 371                                             (point))
 372                                           t)
 373                       (not (re-search-forward gnus-cite-attribution-postfix
 374                                               start t))
 375                       (count-lines (point-min) (1+ (point)))))))
 376       (if (eq wrote in)
 377           (setq in nil))
 378       (goto-char end)
 379       (setq gnus-cite-loose-attribution-alist
 380             (cons (list wrote in prefix tag)
 381                   gnus-cite-loose-attribution-alist))))
 382   ;; Find exact supercite citations.
 383   (gnus-cite-match-attributions 'small nil
 384    (lambda (prefix tag)
 385      (if tag
 386          (concat "\\`" (regexp-quote prefix) "[ \t]*"
 387                  (regexp-quote tag) ">"))))
 388   ;; Find loose supercite citations after attributions.
 389   (gnus-cite-match-attributions 'small t
 390    (lambda (prefix tag)
 391      (if tag (concat "\\<" (regexp-quote tag) "\\>"))))
 392   ;; Find loose supercite citations anywhere.
 393   (gnus-cite-match-attributions 'small nil
 394    (lambda (prefix tag)
 395      (if tag (concat "\\<" (regexp-quote tag) "\\>"))))
 396   ;; Find nested citations after attributions.
 397   (gnus-cite-match-attributions 'small-if-unique t
 398    (lambda (prefix tag)
 399      (concat "\\`" (regexp-quote prefix) ".+")))
 400   ;; Find nested citations anywhere.
 401   (gnus-cite-match-attributions 'small nil
 402    (lambda (prefix tag)
 403      (concat "\\`" (regexp-quote prefix) ".+")))
 404   ;; Remove loose prefixes with too few lines.
 405   (let ((alist gnus-cite-loose-prefix-alist)
 406         entry)
 407     (while alist
 408       (setq entry (car alist)
 409             alist (cdr alist))
 410       (if (< (length (cdr entry)) gnus-cite-minimum-match-count)
 411           (setq gnus-cite-prefix-alist
 412                 (delq entry gnus-cite-prefix-alist)
 413                 gnus-cite-loose-prefix-alist
 414                 (delq entry gnus-cite-loose-prefix-alist)))))
 415   ;; Find flat attributions.
 416   (gnus-cite-match-attributions 'first t nil)
 417   ;; Find any attributions (are we getting desperate yet?).
 418   (gnus-cite-match-attributions 'first nil nil))
 419
 420 (defun gnus-cite-match-attributions (sort after fun)
 421   ;; Match all loose attributions and citations (SORT AFTER FUN) .
 422   ;;
 423   ;; If SORT is `small', the citation with the shortest prefix will be
 424   ;; used, if it is `first' the first prefix will be used, if it is
 425   ;; `small-if-unique' the shortest prefix will be used if the
 426   ;; attribution line does not share its own prefix with other
 427   ;; loose attribution lines, otherwise the first prefix will be used.
 428   ;;
 429   ;; If AFTER is non-nil, only citations after the attribution line
 430   ;; will be concidered.
 431   ;;
 432   ;; If FUN is non-nil, it will be called with the arguments (WROTE
 433   ;; PREFIX TAG) and expected to return a regular expression.  Only
 434   ;; citations whose prefix matches the regular expression will be
 435   ;; concidered.
 436   ;;
 437   ;; WROTE is the attribution line number.
 438   ;; PREFIX is the attribution line prefix.
 439   ;; TAG is the SuperCite tag on the attribution line.
 440   (let ((atts gnus-cite-loose-attribution-alist)
 441         (case-fold-search t)
 442         att wrote in prefix tag regexp limit smallest best size)
 443     (while atts
 444       (setq att (car atts)
 445             atts (cdr atts)
 446             wrote (nth 0 att)
 447             in (nth 1 att)
 448             prefix (nth 2 att)
 449             tag (nth 3 att)
 450             regexp (if fun (funcall fun prefix tag) "")
 451             size (cond ((eq sort 'small) t)
 452                        ((eq sort 'first) nil)
 453                        (t (< (length (gnus-cite-find-loose prefix)) 2)))
 454             limit (if after wrote -1)
 455             smallest 1000000
 456             best nil)
 457       (let ((cites gnus-cite-loose-prefix-alist)
 458             cite candidate numbers first compare)
 459         (while cites
 460           (setq cite (car cites)
 461                 cites (cdr cites)
 462                 candidate (car cite)
 463                 numbers (cdr cite)
 464                 first (apply 'min numbers)
 465                 compare (if size (length candidate) first))
 466           (and (> first limit)
 467                regexp
 468                (string-match regexp candidate)
 469                (< compare smallest)
 470                (setq best cite
 471                      smallest compare))))
 472       (if (null best)
 473           ()
 474         (setq gnus-cite-loose-attribution-alist
 475               (delq att gnus-cite-loose-attribution-alist))
 476         (setq gnus-cite-attribution-alist
 477               (cons (cons wrote (car best)) gnus-cite-attribution-alist))
 478         (if in
 479             (setq gnus-cite-attribution-alist
 480                   (cons (cons in (car best)) gnus-cite-attribution-alist)))
 481         (if (memq best gnus-cite-loose-prefix-alist)
 482            (let ((loop gnus-cite-prefix-alist)
 483                  (numbers (cdr best))
 484                  current)
 485              (setq gnus-cite-loose-prefix-alist
 486                    (delq best gnus-cite-loose-prefix-alist))
 487              (while loop
 488                (setq current (car loop)
 489                      loop (cdr loop))
 490                (if (eq current best)
 491                    ()
 492                  (setcdr current (gnus-set-difference (cdr current) numbers))
 493                  (if (null (cdr current))
 494                      (setq gnus-cite-loose-prefix-alist
 495                            (delq current gnus-cite-loose-prefix-alist)
 496                            atts (delq current atts)))))))))))
 497
 498 (defun gnus-cite-find-loose (prefix)
 499   ;; Return a list of loose attribution lines prefixed by PREFIX.
 500   (let* ((atts gnus-cite-loose-attribution-alist)
 501          att line lines)
 502     (while atts
 503       (setq att (car atts)
 504             line (car att)
 505             atts (cdr atts))
 506       (if (string-equal (gnus-cite-find-prefix line) prefix)
 507           (setq lines (cons line lines))))
 508     lines))
 509
 510 (defun gnus-cite-add-face (number prefix face)
 511   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
 512   (if face
 513       (let ((inhibit-point-motion-hooks t)
 514             from to)
 515         (goto-line number)
 516         (forward-char (length prefix))
 517         (skip-chars-forward " \t")
 518         (setq from (point))
 519         (end-of-line 1)
 520         (skip-chars-backward " \t")
 521         (setq to (point))
 522         (if (< from to)
 523             (overlay-put (make-overlay from to) 'face face)))))
 524
 525 (defun gnus-cite-toggle (prefix)
 526   (save-excursion
 527     (set-buffer gnus-article-buffer)
 528     (let ((buffer-read-only nil)
 529           (numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
 530           (inhibit-point-motion-hooks t)
 531           number)
 532       (while numbers
 533         (setq number (car numbers)
 534               numbers (cdr numbers))
 535         (goto-line number)
 536         (cond ((get-text-property (point) 'invisible)
 537                (remove-text-properties (point) (progn (forward-line 1) (point))
 538                                        gnus-hidden-properties))
 539               ((assq number gnus-cite-attribution-alist))
 540               (t
 541                (add-text-properties (point) (progn (forward-line 1) (point))
 542                                     gnus-hidden-properties)))))))
 543
 544 (defun gnus-cite-find-prefix (line)
 545   ;; Return citation prefix for LINE.
 546   (let ((alist gnus-cite-prefix-alist)
 547         (prefix "")
 548         entry)
 549     (while alist
 550       (setq entry (car alist)
 551             alist (cdr alist))
 552       (if (memq line (cdr entry))
 553           (setq prefix (car entry))))
 554     prefix))
 555
 556 (provide 'gnus-cite)
 557
 558 ;;; gnus-cite.el ends here