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

   1 ;;; gnus-cite.el --- parse citations in articles for Gnus
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006, 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Per Abhiddenware
   7
   8 ;; This file is part of GNU Emacs.
   9
  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)
  13 ;; any later version.
  14
  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.
  19
  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., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30 (eval-when-compile
  31   (when (featurep 'xemacs)
  32     (require 'easy-mmode))) ; for `define-minor-mode'
  33
  34 (require 'gnus)
  35 (require 'gnus-range)
  36 (require 'gnus-art)
  37 (require 'message)      ; for message-cite-prefix-regexp
  38
  39 ;;; Customization:
  40
  41 (defgroup gnus-cite nil
  42   "Citation."
  43   :prefix "gnus-cite-"
  44   :link '(custom-manual "(gnus)Article Highlighting")
  45   :group 'gnus-article)
  46
  47 (defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n"
  48   "Format of opened cited text buttons."
  49   :group 'gnus-cite
  50   :type 'string)
  51
  52 (defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n"
  53   "Format of closed cited text buttons."
  54   :group 'gnus-cite
  55   :type 'string)
  56
  57 (defcustom gnus-cited-lines-visible nil
  58   "The number of lines of hidden cited text to remain visible.
  59 Or a pair (cons) of numbers which are the number of lines at the top
  60 and bottom of the text, respectively, to remain visible."
  61   :group 'gnus-cite
  62   :type '(choice (const :tag "none" nil)
  63                  integer
  64                  (cons :tag "Top and Bottom" integer integer)))
  65
  66 (defcustom gnus-cite-parse-max-size 25000
  67   "Maximum article size (in bytes) where parsing citations is allowed.
  68 Set it to nil to parse all articles."
  69   :group 'gnus-cite
  70   :type '(choice (const :tag "all" nil)
  71                  integer))
  72
  73 (defcustom gnus-cite-max-prefix 20
  74   "Maximum possible length for a citation prefix."
  75   :group 'gnus-cite
  76   :type 'integer)
  77
  78 (defcustom gnus-supercite-regexp
  79   (concat "^\\(" message-cite-prefix-regexp "\\)? *"
  80           ">>>>> +\"\\([^\"\n]+\\)\" +==")
  81   "*Regexp matching normal Supercite attribution lines.
  82 The first grouping must match prefixes added by other packages."
  83   :group 'gnus-cite
  84   :type 'regexp)
  85
  86 (defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
  87   "Regexp matching mangled Supercite attribution lines.
  88 The first regexp group should match the Supercite attribution."
  89   :group 'gnus-cite
  90   :type 'regexp)
  91
  92 (defcustom gnus-cite-minimum-match-count 2
  93   "Minimum number of identical prefixes before we believe it's a citation."
  94   :group 'gnus-cite
  95   :type 'integer)
  96
  97 ;; Some Microsoft products put in a citation that extends to the
  98 ;; remainder of the message:
  99 ;;
 100 ;;     -----Original Message-----
 101 ;;     From: ...
 102 ;;     To: ...
 103 ;;     Sent: ...   [date, in non-RFC-2822 format]
 104 ;;     Subject: ...
 105 ;;
 106 ;;     Cited message, with no prefixes
 107 ;;
 108 ;; The four headers are always the same.  But note they are prone to
 109 ;; folding without additional indentation.
 110 ;;
 111 ;; Others use "----- Original Message -----" instead, and properly quote
 112 ;; the body using "> ".  This style is handled without special cases.
 113
 114 (defcustom gnus-cite-attribution-prefix
 115   "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----"
 116   "*Regexp matching the beginning of an attribution line."
 117   :group 'gnus-cite
 118   :type 'regexp)
 119
 120 (defcustom gnus-cite-attribution-suffix
 121   "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$"
 122   "*Regexp matching the end of an attribution line.
 123 The text matching the first grouping will be used as a button."
 124   :group 'gnus-cite
 125   :type 'regexp)
 126
 127 (defcustom gnus-cite-unsightly-citation-regexp
 128   "^-----Original Message-----\nFrom: \\(.+\n\\)+\n"
 129   "Regexp matching Microsoft-type rest-of-message citations."
 130   :version "22.1"
 131   :group 'gnus-cite
 132   :type 'regexp)
 133
 134 (defcustom gnus-cite-ignore-quoted-from t
 135   "Non-nil means don't regard lines beginning with \">From \" as cited text.
 136 Those lines may have been quoted by MTAs in order not to mix up with
 137 the envelope From line."
 138   :version "22.1"
 139   :group 'gnus-cite
 140   :type 'boolean)
 141
 142 (defface gnus-cite-attribution '((t (:italic t)))
 143   "Face used for attribution lines."
 144   :group 'gnus-cite)
 145 ;; backward-compatibility alias
 146 (put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution)
 147
 148 (defcustom gnus-cite-attribution-face 'gnus-cite-attribution
 149   "Face used for attribution lines.
 150 It is merged with the face for the cited text belonging to the attribution."
 151   :version "22.1"
 152   :group 'gnus-cite
 153   :type 'face)
 154
 155 (defface gnus-cite-1 '((((class color)
 156                          (background dark))
 157                         (:foreground "light blue"))
 158                        (((class color)
 159                          (background light))
 160                         (:foreground "MidnightBlue"))
 161                        (t
 162                         (:italic t)))
 163   "Citation face."
 164   :group 'gnus-cite)
 165 ;; backward-compatibility alias
 166 (put 'gnus-cite-face-1 'face-alias 'gnus-cite-1)
 167
 168 (defface gnus-cite-2 '((((class color)
 169                          (background dark))
 170                         (:foreground "light cyan"))
 171                        (((class color)
 172                          (background light))
 173                         (:foreground "firebrick"))
 174                        (t
 175                         (:italic t)))
 176   "Citation face."
 177   :group 'gnus-cite)
 178 ;; backward-compatibility alias
 179 (put 'gnus-cite-face-2 'face-alias 'gnus-cite-2)
 180
 181 (defface gnus-cite-3 '((((class color)
 182                          (background dark))
 183                         (:foreground "light yellow"))
 184                        (((class color)
 185                          (background light))
 186                         (:foreground "dark green"))
 187                        (t
 188                         (:italic t)))
 189   "Citation face."
 190   :group 'gnus-cite)
 191 ;; backward-compatibility alias
 192 (put 'gnus-cite-face-3 'face-alias 'gnus-cite-3)
 193
 194 (defface gnus-cite-4 '((((class color)
 195                          (background dark))
 196                         (:foreground "light pink"))
 197                        (((class color)
 198                          (background light))
 199                         (:foreground "OrangeRed"))
 200                        (t
 201                         (:italic t)))
 202   "Citation face."
 203   :group 'gnus-cite)
 204 ;; backward-compatibility alias
 205 (put 'gnus-cite-face-4 'face-alias 'gnus-cite-4)
 206
 207 (defface gnus-cite-5 '((((class color)
 208                          (background dark))
 209                         (:foreground "pale green"))
 210                        (((class color)
 211                          (background light))
 212                         (:foreground "dark khaki"))
 213                        (t
 214                         (:italic t)))
 215   "Citation face."
 216   :group 'gnus-cite)
 217 ;; backward-compatibility alias
 218 (put 'gnus-cite-face-5 'face-alias 'gnus-cite-5)
 219
 220 (defface gnus-cite-6 '((((class color)
 221                          (background dark))
 222                         (:foreground "beige"))
 223                        (((class color)
 224                          (background light))
 225                         (:foreground "dark violet"))
 226                        (t
 227                         (:italic t)))
 228   "Citation face."
 229   :group 'gnus-cite)
 230 ;; backward-compatibility alias
 231 (put 'gnus-cite-face-6 'face-alias 'gnus-cite-6)
 232
 233 (defface gnus-cite-7 '((((class color)
 234                          (background dark))
 235                         (:foreground "orange"))
 236                        (((class color)
 237                          (background light))
 238                         (:foreground "SteelBlue4"))
 239                        (t
 240                         (:italic t)))
 241   "Citation face."
 242   :group 'gnus-cite)
 243 ;; backward-compatibility alias
 244 (put 'gnus-cite-face-7 'face-alias 'gnus-cite-7)
 245
 246 (defface gnus-cite-8 '((((class color)
 247                          (background dark))
 248                         (:foreground "magenta"))
 249                        (((class color)
 250                          (background light))
 251                         (:foreground "magenta"))
 252                        (t
 253                         (:italic t)))
 254   "Citation face."
 255   :group 'gnus-cite)
 256 ;; backward-compatibility alias
 257 (put 'gnus-cite-face-8 'face-alias 'gnus-cite-8)
 258
 259 (defface gnus-cite-9 '((((class color)
 260                          (background dark))
 261                         (:foreground "violet"))
 262                        (((class color)
 263                          (background light))
 264                         (:foreground "violet"))
 265                        (t
 266                         (:italic t)))
 267   "Citation face."
 268   :group 'gnus-cite)
 269 ;; backward-compatibility alias
 270 (put 'gnus-cite-face-9 'face-alias 'gnus-cite-9)
 271
 272 (defface gnus-cite-10 '((((class color)
 273                           (background dark))
 274                          (:foreground "medium purple"))
 275                         (((class color)
 276                           (background light))
 277                          (:foreground "medium purple"))
 278                         (t
 279                          (:italic t)))
 280   "Citation face."
 281   :group 'gnus-cite)
 282 ;; backward-compatibility alias
 283 (put 'gnus-cite-face-10 'face-alias 'gnus-cite-10)
 284
 285 (defface gnus-cite-11 '((((class color)
 286                           (background dark))
 287                          (:foreground "turquoise"))
 288                         (((class color)
 289                           (background light))
 290                          (:foreground "turquoise"))
 291                         (t
 292                          (:italic t)))
 293   "Citation face."
 294   :group 'gnus-cite)
 295 ;; backward-compatibility alias
 296 (put 'gnus-cite-face-11 'face-alias 'gnus-cite-11)
 297
 298 (defcustom gnus-cite-face-list
 299   '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6
 300     gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11)
 301   "*List of faces used for highlighting citations.
 302
 303 When there are citations from multiple articles in the same message,
 304 Gnus will try to give each citation from each article its own face.
 305 This should make it easier to see who wrote what."
 306   :group 'gnus-cite
 307   :type '(repeat face))
 308
 309 (defcustom gnus-cite-hide-percentage 50
 310   "Only hide excess citation if above this percentage of the body."
 311   :group 'gnus-cite
 312   :type 'number)
 313
 314 (defcustom gnus-cite-hide-absolute 10
 315   "Only hide excess citation if above this number of lines in the body."
 316   :group 'gnus-cite
 317   :type 'integer)
 318
 319 (defcustom gnus-cite-blank-line-after-header t
 320   "If non-nil, put a blank line between the citation header and the button."
 321   :group 'gnus-cite
 322   :type 'boolean)
 323
 324 ;; This has to go here because its default value depends on
 325 ;; gnus-cite-face-list.
 326 (defcustom gnus-article-boring-faces (cons 'gnus-signature gnus-cite-face-list)
 327   "List of faces that are not worth reading.
 328 If an article has more pages below the one you are looking at, but
 329 nothing on those pages is a word of at least three letters that is not
 330 in a boring face, then the pages will be skipped."
 331   :type '(repeat face)
 332   :group 'gnus-article-hiding)
 333
 334 ;;; Internal Variables:
 335
 336 (defvar gnus-cite-article nil)
 337 (defvar gnus-cite-overlay-list nil)
 338
 339 (defvar gnus-cite-prefix-alist nil)
 340 ;; Alist of citation prefixes.
 341 ;; The cdr is a list of lines with that prefix.
 342
 343 (defvar gnus-cite-attribution-alist nil)
 344 ;; Alist of attribution lines.
 345 ;; The car is a line number.
 346 ;; The cdr is the prefix for the citation started by that line.
 347
 348 (defvar gnus-cite-loose-prefix-alist nil)
 349 ;; Alist of citation prefixes that have no matching attribution.
 350 ;; The cdr is a list of lines with that prefix.
 351
 352 (defvar gnus-cite-loose-attribution-alist nil)
 353 ;; Alist of attribution lines that have no matching citation.
 354 ;; Each member has the form (WROTE IN PREFIX TAG), where
 355 ;; WROTE: is the attribution line number
 356 ;; IN: is the line number of the previous line if part of the same attribution,
 357 ;; PREFIX: Is the citation prefix of the attribution line(s), and
 358 ;; TAG: Is a Supercite tag, if any.
 359
 360 (defvar gnus-cited-opened-text-button-line-format-alist
 361   `((?b (marker-position beg) ?d)
 362     (?e (marker-position end) ?d)
 363     (?n (count-lines beg end) ?d)
 364     (?l (- end beg) ?d)))
 365 (defvar gnus-cited-opened-text-button-line-format-spec nil)
 366 (defvar gnus-cited-closed-text-button-line-format-alist
 367   gnus-cited-opened-text-button-line-format-alist)
 368 (defvar gnus-cited-closed-text-button-line-format-spec nil)
 369
 370
 371 ;;; Commands:
 372
 373 (defun gnus-article-highlight-citation (&optional force same-buffer)
 374   "Highlight cited text.
 375 Each citation in the article will be highlighted with a different face.
 376 The faces are taken from `gnus-cite-face-list'.
 377 Attribution lines are highlighted with the same face as the
 378 corresponding citation merged with the face `gnus-cite-attribution'.
 379
 380 Text is considered cited if at least `gnus-cite-minimum-match-count'
 381 lines matches `message-cite-prefix-regexp' with the same prefix.
 382
 383 Lines matching `gnus-cite-attribution-suffix' and perhaps
 384 `gnus-cite-attribution-prefix' are considered attribution lines."
 385   (interactive (list 'force))
 386   (save-excursion
 387     (unless same-buffer
 388       (set-buffer gnus-article-buffer))
 389     (gnus-cite-parse-maybe force)
 390     (let ((buffer-read-only nil)
 391           (alist gnus-cite-prefix-alist)
 392           (faces gnus-cite-face-list)
 393           (inhibit-point-motion-hooks t)
 394           face entry prefix skip numbers number face-alist)
 395       ;; Loop through citation prefixes.
 396       (while alist
 397         (setq entry (car alist)
 398               alist (cdr alist)
 399               prefix (car entry)
 400               numbers (cdr entry)
 401               face (car faces)
 402               faces (or (cdr faces) gnus-cite-face-list)
 403               face-alist (cons (cons prefix face) face-alist))
 404         (while numbers
 405           (setq number (car numbers)
 406                 numbers (cdr numbers))
 407           (and (not (assq number gnus-cite-attribution-alist))
 408                (not (assq number gnus-cite-loose-attribution-alist))
 409                (gnus-cite-add-face number prefix face))))
 410       ;; Loop through attribution lines.
 411       (setq alist gnus-cite-attribution-alist)
 412       (while alist
 413         (setq entry (car alist)
 414               alist (cdr alist)
 415               number (car entry)
 416               prefix (cdr entry)
 417               skip (gnus-cite-find-prefix number)
 418               face (cdr (assoc prefix face-alist)))
 419         ;; Add attribution button.
 420         (goto-char (point-min))
 421         (forward-line (1- number))
 422         (when (re-search-forward gnus-cite-attribution-suffix
 423                                  (point-at-eol)
 424                                  t)
 425           (gnus-article-add-button (match-beginning 1) (match-end 1)
 426                                    'gnus-cite-toggle prefix))
 427         ;; Highlight attribution line.
 428         (gnus-cite-add-face number skip face)
 429         (gnus-cite-add-face number skip gnus-cite-attribution-face))
 430       ;; Loop through attribution lines.
 431       (setq alist gnus-cite-loose-attribution-alist)
 432       (while alist
 433         (setq entry (car alist)
 434               alist (cdr alist)
 435               number (car entry)
 436               skip (gnus-cite-find-prefix number))
 437         (gnus-cite-add-face number skip gnus-cite-attribution-face)))))
 438
 439 (defun gnus-dissect-cited-text ()
 440   "Dissect the article buffer looking for cited text."
 441   (save-excursion
 442     (set-buffer gnus-article-buffer)
 443     (gnus-cite-parse-maybe nil t)
 444     (let ((alist gnus-cite-prefix-alist)
 445           prefix numbers number marks m)
 446       ;; Loop through citation prefixes.
 447       (while alist
 448         (setq numbers (pop alist)
 449               prefix (pop numbers))
 450         (while numbers
 451           (setq number (pop numbers))
 452           (goto-char (point-min))
 453           (forward-line number)
 454           (push (cons (point-marker) "") marks)
 455           (while (and numbers
 456                       (= (1- number) (car numbers)))
 457             (setq number (pop numbers)))
 458           (goto-char (point-min))
 459           (forward-line (1- number))
 460           (push (cons (point-marker) prefix) marks)))
 461       ;; Skip to the beginning of the body.
 462       (article-goto-body)
 463       (push (cons (point-marker) "") marks)
 464       ;; Find the end of the body.
 465       (goto-char (point-max))
 466       (gnus-article-search-signature)
 467       (push (cons (point-marker) "") marks)
 468       ;; Sort the marks.
 469       (setq marks (sort marks 'car-less-than-car))
 470       (let ((omarks marks))
 471         (setq marks nil)
 472         (while (cdr omarks)
 473           (if (= (caar omarks) (caadr omarks))
 474               (progn
 475                 (unless (equal (cdar omarks) "")
 476                   (push (car omarks) marks))
 477                 (unless (equal (cdadr omarks) "")
 478                   (push (cadr omarks) marks))
 479                 (unless (and (equal (cdar omarks) "")
 480                              (equal (cdadr omarks) "")
 481                              (not (cddr omarks)))
 482                   (setq omarks (cdr omarks))))
 483             (push (car omarks) marks))
 484           (setq omarks (cdr omarks)))
 485         (when (car omarks)
 486           (push (car omarks) marks))
 487         (setq marks (setq m (nreverse marks)))
 488         (while (cddr m)
 489           (if (and (equal (cdadr m) "")
 490                    (equal (cdar m) (cdaddr m))
 491                    (goto-char (caadr m))
 492                    (forward-line 1)
 493                    (= (point) (caaddr m)))
 494               (setcdr m (cdddr m))
 495             (setq m (cdr m))))
 496         marks))))
 497
 498 (defun gnus-article-fill-cited-article (&optional force width)
 499   "Do word wrapping in the current article.
 500 If WIDTH (the numerical prefix), use that text width when filling."
 501   (interactive (list t current-prefix-arg))
 502   (save-excursion
 503     (set-buffer gnus-article-buffer)
 504     (let ((buffer-read-only nil)
 505           (inhibit-point-motion-hooks t)
 506           (marks (gnus-dissect-cited-text))
 507           (adaptive-fill-mode nil)
 508           (filladapt-mode nil)
 509           (fill-column (if width (prefix-numeric-value width) fill-column)))
 510       (save-restriction
 511         (while (cdr marks)
 512           (narrow-to-region (caar marks) (caadr marks))
 513           (let ((adaptive-fill-regexp
 514                  (concat "^" (regexp-quote (cdar marks)) " *"))
 515                 (fill-prefix
 516                  (if (string= (cdar marks) "") ""
 517                    (concat (cdar marks) " ")))
 518                 use-hard-newlines)
 519             (fill-region (point-min) (point-max)))
 520           (set-marker (caar marks) nil)
 521           (setq marks (cdr marks)))
 522         (when marks
 523           (set-marker (caar marks) nil))
 524         ;; All this information is now incorrect.
 525         (setq gnus-cite-prefix-alist nil
 526               gnus-cite-attribution-alist nil
 527               gnus-cite-loose-prefix-alist nil
 528               gnus-cite-loose-attribution-alist nil
 529               gnus-cite-article nil)))))
 530
 531 (defun gnus-article-hide-citation (&optional arg force)
 532   "Toggle hiding of all cited text except attribution lines.
 533 See the documentation for `gnus-article-highlight-citation'.
 534 If given a negative prefix, always show; if given a positive prefix,
 535 always hide."
 536   (interactive (append (gnus-article-hidden-arg) (list 'force)))
 537   (gnus-set-format 'cited-opened-text-button t)
 538   (gnus-set-format 'cited-closed-text-button t)
 539   (save-excursion
 540     (set-buffer gnus-article-buffer)
 541       (let ((buffer-read-only nil)
 542             marks
 543             (inhibit-point-motion-hooks t)
 544             (props (nconc (list 'article-type 'cite)
 545                           gnus-hidden-properties))
 546             (point (point-min))
 547             found beg end start)
 548         (while (setq point
 549                      (text-property-any point (point-max)
 550                                         'gnus-callback
 551                                         'gnus-article-toggle-cited-text))
 552           (setq found t)
 553           (goto-char point)
 554           (gnus-article-toggle-cited-text
 555            (get-text-property point 'gnus-data) arg)
 556           (forward-line 1)
 557           (setq point (point)))
 558         (unless found
 559           (setq marks (gnus-dissect-cited-text))
 560           (while marks
 561             (setq beg nil
 562                   end nil)
 563             (while (and marks (string= (cdar marks) ""))
 564               (setq marks (cdr marks)))
 565             (when marks
 566               (setq beg (caar marks)))
 567             (while (and marks (not (string= (cdar marks) "")))
 568               (setq marks (cdr marks)))
 569             (when marks
 570             (setq end (caar marks)))
 571             ;; Skip past lines we want to leave visible.
 572             (when (and beg end gnus-cited-lines-visible)
 573               (goto-char beg)
 574               (forward-line (if (consp gnus-cited-lines-visible)
 575                                 (car gnus-cited-lines-visible)
 576                               gnus-cited-lines-visible))
 577               (if (>= (point) end)
 578                   (setq beg nil)
 579                 (setq beg (point-marker))
 580                 (when (consp gnus-cited-lines-visible)
 581                   (goto-char end)
 582                   (forward-line (- (cdr gnus-cited-lines-visible)))
 583                   (if (<= (point) beg)
 584                       (setq beg nil)
 585                   (setq end (point-marker))))))
 586             (when (and beg end)
 587               (gnus-add-wash-type 'cite)
 588               ;; We use markers for the end-points to facilitate later
 589               ;; wrapping and mangling of text.
 590               (setq beg (set-marker (make-marker) beg)
 591                     end (set-marker (make-marker) end))
 592               (gnus-add-text-properties-when 'article-type nil beg end props)
 593               (goto-char beg)
 594               (when (and gnus-cite-blank-line-after-header
 595                          (not (save-excursion (search-backward "\n\n" nil t))))
 596                 (insert "\n"))
 597               (put-text-property
 598                (setq start (point-marker))
 599                (progn
 600                (gnus-article-add-button
 601                 (point)
 602                 (progn (eval gnus-cited-closed-text-button-line-format-spec)
 603                        (point))
 604                 `gnus-article-toggle-cited-text
 605                 (list (cons beg end) start))
 606                (point))
 607                'article-type 'annotation)
 608               (set-marker beg (point))))))))
 609
 610 (defun gnus-article-toggle-cited-text (args &optional arg)
 611   "Toggle hiding the text in REGION.
 612 ARG can be nil or a number.  Positive means hide, negative
 613 means show, nil means toggle."
 614   (let* ((region (car args))
 615          (beg (car region))
 616          (end (cdr region))
 617          (start (cadr args))
 618          (hidden
 619           (text-property-any beg (1- end) 'article-type 'cite))
 620          (inhibit-point-motion-hooks t)
 621          buffer-read-only)
 622     (when (or (null arg)
 623               (zerop arg)
 624               (and (> arg 0) (not hidden))
 625               (and (< arg 0) hidden))
 626       (if hidden
 627           (progn
 628             ;; Can't remove 'cite from g-a-wash-types here because
 629             ;; multiple citations may be hidden -jas
 630             (gnus-remove-text-properties-when
 631              'article-type 'cite beg end
 632              (cons 'article-type (cons 'cite
 633                                        gnus-hidden-properties))))
 634         (gnus-add-wash-type 'cite)
 635         (gnus-add-text-properties-when
 636          'article-type nil beg end
 637          (cons 'article-type (cons 'cite
 638                                    gnus-hidden-properties))))
 639       (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
 640         (gnus-set-mode-line 'article))
 641       (save-excursion
 642         (goto-char start)
 643         (gnus-delete-line)
 644         (put-text-property
 645          (point)
 646          (progn
 647            (gnus-article-add-button
 648             (point)
 649             (progn (eval
 650                     (if hidden
 651                         gnus-cited-opened-text-button-line-format-spec
 652                       gnus-cited-closed-text-button-line-format-spec))
 653                    (point))
 654             `gnus-article-toggle-cited-text
 655             args)
 656            (point))
 657          'article-type 'annotation)))))
 658
 659 (defun gnus-article-hide-citation-maybe (&optional arg force)
 660   "Toggle hiding of cited text that has an attribution line.
 661 If given a negative prefix, always show; if given a positive prefix,
 662 always hide.
 663 This will do nothing unless at least `gnus-cite-hide-percentage'
 664 percent and at least `gnus-cite-hide-absolute' lines of the body is
 665 cited text with attributions.  When called interactively, these two
 666 variables are ignored.
 667 See also the documentation for `gnus-article-highlight-citation'."
 668   (interactive (append (gnus-article-hidden-arg) '(force)))
 669   (with-current-buffer gnus-article-buffer
 670     (gnus-delete-wash-type 'cite)
 671     (unless (gnus-article-check-hidden-text 'cite arg)
 672       (save-excursion
 673         (gnus-cite-parse-maybe force)
 674         (article-goto-body)
 675         (let ((start (point))
 676               (atts gnus-cite-attribution-alist)
 677               (buffer-read-only nil)
 678               (inhibit-point-motion-hooks t)
 679               (hidden 0)
 680               total)
 681           (goto-char (point-max))
 682           (gnus-article-search-signature)
 683           (setq total (count-lines start (point)))
 684           (while atts
 685             (setq hidden (+ hidden (length (cdr (assoc (cdar atts)
 686                                                        gnus-cite-prefix-alist))))
 687                   atts (cdr atts)))
 688           (when (or force
 689                     (and (> (* 100 hidden) (* gnus-cite-hide-percentage total))
 690                          (> hidden gnus-cite-hide-absolute)))
 691             (gnus-add-wash-type 'cite)
 692             (setq atts gnus-cite-attribution-alist)
 693             (while atts
 694               (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
 695                     atts (cdr atts))
 696               (while total
 697                 (setq hidden (car total)
 698                       total (cdr total))
 699                 (goto-char (point-min))
 700                 (forward-line (1- hidden))
 701                 (unless (assq hidden gnus-cite-attribution-alist)
 702                   (gnus-add-text-properties
 703                    (point) (progn (forward-line 1) (point))
 704                    (nconc (list 'article-type 'cite)
 705                           gnus-hidden-properties)))))))))
 706     (gnus-set-mode-line 'article)))
 707
 708 (defun gnus-article-hide-citation-in-followups ()
 709   "Hide cited text in non-root articles."
 710   (interactive)
 711   (save-excursion
 712     (set-buffer gnus-article-buffer)
 713     (let ((article (cdr gnus-article-current)))
 714       (unless (save-excursion
 715                 (set-buffer gnus-summary-buffer)
 716                 (gnus-article-displayed-root-p article))
 717         (gnus-article-hide-citation)))))
 718
 719 ;;; Internal functions:
 720
 721 (defun gnus-cite-parse-maybe (&optional force no-overlay)
 722   "Always parse the buffer."
 723   (gnus-cite-localize)
 724   ;;Reset parser information.
 725   (setq gnus-cite-prefix-alist nil
 726         gnus-cite-attribution-alist nil
 727         gnus-cite-loose-prefix-alist nil
 728         gnus-cite-loose-attribution-alist nil)
 729   (unless no-overlay
 730     (gnus-cite-delete-overlays))
 731   ;; Parse if not too large.
 732   (if (and gnus-cite-parse-max-size
 733            (> (buffer-size) gnus-cite-parse-max-size))
 734       ()
 735     (setq gnus-cite-article (cons (car gnus-article-current)
 736                                   (cdr gnus-article-current)))
 737     (gnus-cite-parse-wrapper)))
 738
 739 (defun gnus-cite-delete-overlays ()
 740   (dolist (overlay gnus-cite-overlay-list)
 741     (ignore-errors
 742       (when (or (not (gnus-overlay-end overlay))
 743                 (and (>= (gnus-overlay-end overlay) (point-min))
 744                      (<= (gnus-overlay-end overlay) (point-max))))
 745         (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list))
 746         (ignore-errors
 747           (gnus-delete-overlay overlay))))))
 748
 749 (defun gnus-cite-parse-wrapper ()
 750   ;; Wrap chopped gnus-cite-parse.
 751   (article-goto-body)
 752   (let ((inhibit-point-motion-hooks t))
 753     (save-excursion
 754       (gnus-cite-parse-attributions))
 755     (save-excursion
 756       (gnus-cite-parse))
 757     (save-excursion
 758       (gnus-cite-connect-attributions))))
 759
 760 (defun gnus-cite-parse ()
 761   ;; Parse and connect citation prefixes and attribution lines.
 762
 763   ;; Parse current buffer searching for citation prefixes.
 764   (let ((line (1+ (count-lines (point-min) (point))))
 765         (case-fold-search t)
 766         (max (save-excursion
 767                (goto-char (point-max))
 768                (gnus-article-search-signature)
 769                (point)))
 770         (prefix-regexp (concat "^\\(" message-cite-prefix-regexp "\\)"))
 771         alist entry start begin end numbers prefix guess-limit)
 772     ;; Get all potential prefixes in `alist'.
 773     (while (< (point) max)
 774       ;; Each line.
 775       (setq begin (point)
 776             guess-limit (progn (skip-chars-forward "^> \t\r\n") (point))
 777             end (point-at-bol 2)
 778             start end)
 779       (goto-char begin)
 780       ;; Ignore standard Supercite attribution prefix.
 781       (when (and (< guess-limit (+ begin gnus-cite-max-prefix))
 782                  (looking-at gnus-supercite-regexp))
 783         (if (match-end 1)
 784             (setq end (1+ (match-end 1)))
 785           (setq end (1+ begin))))
 786       ;; Ignore very long prefixes.
 787       (when (> end (+ begin gnus-cite-max-prefix))
 788         (setq end (+ begin gnus-cite-max-prefix)))
 789       ;; Ignore quoted envelope From_.
 790       (when (and gnus-cite-ignore-quoted-from
 791                  (prog2
 792                      (setq case-fold-search nil)
 793                      (looking-at ">From ")
 794                    (setq case-fold-search t)))
 795         (setq end (1+ begin)))
 796       (while (re-search-forward prefix-regexp (1- end) t)
 797         ;; Each prefix.
 798         (setq end (match-end 0)
 799               prefix (buffer-substring begin end))
 800         (set-text-properties 0 (length prefix) nil prefix)
 801         (setq entry (assoc prefix alist))
 802         (if entry
 803             (setcdr entry (cons line (cdr entry)))
 804           (push (list prefix line) alist))
 805         (goto-char begin))
 806       (goto-char start)
 807       (setq line (1+ line)))
 808     ;; Horrible special case for some Microsoft mailers.
 809     (goto-char (point-min))
 810     (when (re-search-forward gnus-cite-unsightly-citation-regexp max t)
 811       (setq begin (count-lines (point-min) (point)))
 812       (setq end (count-lines (point-min) max))
 813       (setq entry nil)
 814       (while (< begin end)
 815         (push begin entry)
 816         (setq begin (1+ begin)))
 817       (push (cons "" entry) alist))
 818     ;; We got all the potential prefixes.  Now create
 819     ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
 820     ;; line that appears at least `gnus-cite-minimum-match-count'
 821     ;; times.  First sort them by length.  Longer is older.
 822     (setq alist (sort alist (lambda (a b)
 823                               (> (length (car a)) (length (car b))))))
 824     (while alist
 825       (setq entry (car alist)
 826             prefix (car entry)
 827             numbers (cdr entry)
 828             alist (cdr alist))
 829       (cond ((null numbers)
 830              ;; No lines with this prefix that wasn't also part of
 831              ;; a longer prefix.
 832              )
 833             ((< (length numbers) gnus-cite-minimum-match-count)
 834              ;; Too few lines with this prefix.  We keep it a bit
 835              ;; longer in case it is an exact match for an attribution
 836              ;; line, but we don't remove the line from other
 837              ;; prefixes.
 838              (push entry gnus-cite-prefix-alist))
 839             (t
 840              (push entry
 841                    gnus-cite-prefix-alist)
 842              ;; Remove articles from other prefixes.
 843              (let ((loop alist)
 844                    current)
 845                (while loop
 846                  (setq current (car loop)
 847                        loop (cdr loop))
 848                  (setcdr current
 849                          (gnus-set-difference (cdr current) numbers)))))))))
 850
 851 (defun gnus-cite-parse-attributions ()
 852   (let (al-alist)
 853     ;; Parse attributions
 854     (while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
 855       (let* ((start (match-beginning 0))
 856              (end (match-end 0))
 857              (wrote (count-lines (point-min) end))
 858              (prefix (gnus-cite-find-prefix wrote))
 859              ;; Check previous line for an attribution leader.
 860              (tag (progn
 861                     (beginning-of-line 1)
 862                     (when (looking-at gnus-supercite-secondary-regexp)
 863                       (buffer-substring (match-beginning 1)
 864                                         (match-end 1)))))
 865              (in (progn
 866                    (goto-char start)
 867                    (and (re-search-backward gnus-cite-attribution-prefix
 868                                             (save-excursion
 869                                               (beginning-of-line 0)
 870                                               (point))
 871                                             t)
 872                         (not (re-search-forward gnus-cite-attribution-suffix
 873                                                 start t))
 874                         (count-lines (point-min) (1+ (point)))))))
 875         (when (eq wrote in)
 876           (setq in nil))
 877         (goto-char end)
 878         ;; don't add duplicates
 879         (let ((al (buffer-substring (save-excursion (beginning-of-line 0)
 880                                                     (1+ (point)))
 881                                     end)))
 882           (when (not (assoc al al-alist))
 883             (push (list wrote in prefix tag)
 884                   gnus-cite-loose-attribution-alist)
 885             (push (cons al t) al-alist)))))))
 886
 887 (defun gnus-cite-connect-attributions ()
 888   ;; Connect attributions to citations
 889
 890   ;; No citations have been connected to attribution lines yet.
 891   (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil))
 892
 893   ;; Parse current buffer searching for attribution lines.
 894   ;; Find exact supercite citations.
 895   (gnus-cite-match-attributions 'small nil
 896                                 (lambda (prefix tag)
 897                                   (when tag
 898                                     (concat "\\`"
 899                                             (regexp-quote prefix) "[ \t]*"
 900                                             (regexp-quote tag) ">"))))
 901   ;; Find loose supercite citations after attributions.
 902   (gnus-cite-match-attributions 'small t
 903                                 (lambda (prefix tag)
 904                                   (when tag
 905                                     (concat "\\<"
 906                                             (regexp-quote tag)
 907                                             "\\>"))))
 908   ;; Find loose supercite citations anywhere.
 909   (gnus-cite-match-attributions 'small nil
 910                                 (lambda (prefix tag)
 911                                   (when tag
 912                                     (concat "\\<"
 913                                             (regexp-quote tag)
 914                                             "\\>"))))
 915   ;; Find nested citations after attributions.
 916   (gnus-cite-match-attributions 'small-if-unique t
 917                                 (lambda (prefix tag)
 918                                   (concat "\\`" (regexp-quote prefix) ".+")))
 919   ;; Find nested citations anywhere.
 920   (gnus-cite-match-attributions 'small nil
 921                                 (lambda (prefix tag)
 922                                   (concat "\\`" (regexp-quote prefix) ".+")))
 923   ;; Remove loose prefixes with too few lines.
 924   (let ((alist gnus-cite-loose-prefix-alist)
 925         entry)
 926     (while alist
 927       (setq entry (car alist)
 928             alist (cdr alist))
 929       (when (< (length (cdr entry)) gnus-cite-minimum-match-count)
 930         (setq gnus-cite-prefix-alist
 931               (delq entry gnus-cite-prefix-alist)
 932               gnus-cite-loose-prefix-alist
 933               (delq entry gnus-cite-loose-prefix-alist)))))
 934   ;; Find flat attributions.
 935   (gnus-cite-match-attributions 'first t nil)
 936   ;; Find any attributions (are we getting desperate yet?).
 937   (gnus-cite-match-attributions 'first nil nil))
 938
 939 (defun gnus-cite-match-attributions (sort after fun)
 940   ;; Match all loose attributions and citations (SORT AFTER FUN) .
 941   ;;
 942   ;; If SORT is `small', the citation with the shortest prefix will be
 943   ;; used, if it is `first' the first prefix will be used, if it is
 944   ;; `small-if-unique' the shortest prefix will be used if the
 945   ;; attribution line does not share its own prefix with other
 946   ;; loose attribution lines, otherwise the first prefix will be used.
 947   ;;
 948   ;; If AFTER is non-nil, only citations after the attribution line
 949   ;; will be considered.
 950   ;;
 951   ;; If FUN is non-nil, it will be called with the arguments (WROTE
 952   ;; PREFIX TAG) and expected to return a regular expression.  Only
 953   ;; citations whose prefix matches the regular expression will be
 954   ;; considered.
 955   ;;
 956   ;; WROTE is the attribution line number.
 957   ;; PREFIX is the attribution line prefix.
 958   ;; TAG is the Supercite tag on the attribution line.
 959   (let ((atts gnus-cite-loose-attribution-alist)
 960         (case-fold-search t)
 961         att wrote in prefix tag regexp limit smallest best size)
 962     (while atts
 963       (setq att (car atts)
 964             atts (cdr atts)
 965             wrote (nth 0 att)
 966             in (nth 1 att)
 967             prefix (nth 2 att)
 968             tag (nth 3 att)
 969             regexp (if fun (funcall fun prefix tag) "")
 970             size (cond ((eq sort 'small) t)
 971                        ((eq sort 'first) nil)
 972                        (t (< (length (gnus-cite-find-loose prefix)) 2)))
 973             limit (if after wrote -1)
 974             smallest 1000000
 975             best nil)
 976       (let ((cites gnus-cite-loose-prefix-alist)
 977             cite candidate numbers first compare)
 978         (while cites
 979           (setq cite (car cites)
 980                 cites (cdr cites)
 981                 candidate (car cite)
 982                 numbers (cdr cite)
 983                 first (apply 'min numbers)
 984                 compare (if size (length candidate) first))
 985           (and (> first limit)
 986                regexp
 987                (string-match regexp candidate)
 988                (< compare smallest)
 989                (setq best cite
 990                      smallest compare))))
 991       (if (null best)
 992           ()
 993         (setq gnus-cite-loose-attribution-alist
 994               (delq att gnus-cite-loose-attribution-alist))
 995         (push (cons wrote (car best)) gnus-cite-attribution-alist)
 996         (when in
 997           (push (cons in (car best)) gnus-cite-attribution-alist))
 998         (when (memq best gnus-cite-loose-prefix-alist)
 999           (let ((loop gnus-cite-prefix-alist)
1000                 (numbers (cdr best))
1001                 current)
1002             (setq gnus-cite-loose-prefix-alist
1003                   (delq best gnus-cite-loose-prefix-alist))
1004             (while loop
1005               (setq current (car loop)
1006                     loop (cdr loop))
1007               (if (eq current best)
1008                   ()
1009                 (setcdr current (gnus-set-difference (cdr current) numbers))
1010                 (when (null (cdr current))
1011                   (setq gnus-cite-loose-prefix-alist
1012                         (delq current gnus-cite-loose-prefix-alist)
1013                         atts (delq current atts)))))))))))
1014
1015 (defun gnus-cite-find-loose (prefix)
1016   ;; Return a list of loose attribution lines prefixed by PREFIX.
1017   (let* ((atts gnus-cite-loose-attribution-alist)
1018          att line lines)
1019     (while atts
1020       (setq att (car atts)
1021             line (car att)
1022             atts (cdr atts))
1023       (when (string-equal (gnus-cite-find-prefix line) prefix)
1024         (push line lines)))
1025     lines))
1026
1027 (defun gnus-cite-add-face (number prefix face)
1028   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
1029   (when face
1030     (let ((inhibit-point-motion-hooks t)
1031           from to overlay)
1032       (goto-char (point-min))
1033       (when (zerop (forward-line (1- number)))
1034         (forward-char (length prefix))
1035         (skip-chars-forward " \t")
1036         (setq from (point))
1037         (end-of-line 1)
1038         (skip-chars-backward " \t")
1039         (setq to (point))
1040         (when (< from to)
1041           (push (setq overlay (gnus-make-overlay from to))
1042                 gnus-cite-overlay-list)
1043           (gnus-overlay-put overlay 'evaporate t)
1044           (gnus-overlay-put overlay 'face face))))))
1045
1046 (defun gnus-cite-toggle (prefix)
1047   (save-excursion
1048     (set-buffer gnus-article-buffer)
1049     (gnus-cite-parse-maybe nil t)
1050     (let ((buffer-read-only nil)
1051           (numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
1052           (inhibit-point-motion-hooks t)
1053           number)
1054       (while numbers
1055         (setq number (car numbers)
1056               numbers (cdr numbers))
1057         (goto-char (point-min))
1058         (forward-line (1- number))
1059         (cond ((get-text-property (point) 'invisible)
1060                ;; Can't remove 'cite from g-a-wash-types here because
1061                ;; multiple citations may be hidden -jas
1062                (remove-text-properties (point) (progn (forward-line 1) (point))
1063                                        gnus-hidden-properties))
1064               ((assq number gnus-cite-attribution-alist))
1065               (t
1066                (gnus-add-wash-type 'cite)
1067                (gnus-add-text-properties
1068                 (point) (progn (forward-line 1) (point))
1069                 (nconc (list 'article-type 'cite)
1070                        gnus-hidden-properties))))
1071         (let ((gnus-article-mime-handle-alist-1
1072                gnus-article-mime-handle-alist))
1073           (gnus-set-mode-line 'article))))))
1074
1075 (defun gnus-cite-find-prefix (line)
1076   ;; Return citation prefix for LINE.
1077   (let ((alist gnus-cite-prefix-alist)
1078         (prefix "")
1079         entry)
1080     (while alist
1081       (setq entry (car alist)
1082             alist (cdr alist))
1083       (when (memq line (cdr entry))
1084         (setq prefix (car entry))))
1085     prefix))
1086
1087 (defun gnus-cite-localize ()
1088   "Make the citation variables local to the article buffer."
1089   (let ((vars '(gnus-cite-article
1090                 gnus-cite-overlay-list gnus-cite-prefix-alist
1091                 gnus-cite-attribution-alist gnus-cite-loose-prefix-alist
1092                 gnus-cite-loose-attribution-alist)))
1093     (while vars
1094       (make-local-variable (pop vars)))))
1095
1096 (defun gnus-cited-line-p ()
1097   "Say whether the current line is a cited line."
1098   (save-excursion
1099     (beginning-of-line)
1100     (let ((found nil))
1101       (dolist (prefix (mapcar 'car gnus-cite-prefix-alist))
1102         (when (string= (buffer-substring (point) (+ (length prefix) (point)))
1103                        prefix)
1104           (setq found t)))
1105       found)))
1106
1107
1108 ;; Highlighting of different citation levels in message-mode.
1109 ;;
1110 ;; Known bugs:
1111 ;;
1112 ;; - XEmacs compatibility: `font-lock-add-keywords' is missing in XEmacs.
1113 ;;
1114 ;; - message-cite-prefix should not be fontified.
1115
1116 (defconst gnus-message-max-citation-depth
1117   (length gnus-cite-face-list)
1118   "Maximum supported level of citation.")
1119
1120 (defun gnus-message-search-citation-line (limit)
1121   "Search for a cited line and set match data accordingly.
1122 Returns nil if there is no such line before LIMIT, t otherwise."
1123   (when (re-search-forward (eval-when-compile
1124                              (concat "^\\(?:"
1125                                      message-cite-prefix-regexp
1126                                      "\\)"))
1127                            limit t)
1128     (let ((cdepth
1129            (length (apply 'concat
1130                           (split-string
1131                            (match-string-no-properties 0)
1132                            "[ \t [:alnum:]]+"))))
1133           (mlist (make-list (* (1+ gnus-message-max-citation-depth)
1134                                2)
1135                             0)))
1136       (setcar (nthcdr (* cdepth 2) mlist)
1137               (line-beginning-position))
1138       (setcar (nthcdr (1+ (* cdepth 2)) mlist)
1139               (line-end-position))
1140       (set-match-data mlist))
1141     t))
1142
1143 (defvar gnus-message-citation-keywords
1144   ;; eval-when-compile ;; This breaks in XEmacs
1145   `((gnus-message-search-citation-line
1146      ,@(let ((list nil)
1147              (count 1))
1148          ;; (require 'gnus-cite)
1149          (dolist (face gnus-cite-face-list (nreverse list))
1150            (push (list count (list 'quote face) 'prepend) list)
1151            (setq count (1+ count)))))) ;;
1152   "Keywords for highlighting different levels of message citations.")
1153
1154 (defun gnus-message-add-citation-keywords ()
1155   "Add font-lock for nested citations to current buffer."
1156   (if (fboundp 'font-lock-add-keywords)
1157       (font-lock-add-keywords nil gnus-message-citation-keywords)
1158     (gnus-message 1 "`font-lock-add-keywords' not supported.")))
1159
1160 (defun gnus-message-remove-citation-keywords ()
1161   "Remove font-lock for nested citations from current buffer."
1162   (if (fboundp 'font-lock-remove-keywords)
1163       (font-lock-remove-keywords nil gnus-message-citation-keywords)
1164     (gnus-message 1 "`font-lock-remove-keywords' not supported.")))
1165
1166 (define-minor-mode gnus-message-citation-mode
1167   "Toggle `gnus-message-citation-mode' in current buffer.
1168 This buffer local minor mode provides additional font-lock support for
1169 nested citations.
1170 With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG is
1171 positive."
1172   nil ;; init-value
1173   "" ;; lighter
1174   nil ;; keymap
1175   (if gnus-message-citation-mode
1176       (gnus-message-add-citation-keywords)
1177     (gnus-message-remove-citation-keywords))
1178   (font-lock-fontify-buffer))
1179
1180 (defun turn-on-gnus-message-citation-mode ()
1181   "Turn on `gnus-message-citation-mode'."
1182   (gnus-message-citation-mode 1))
1183 (defun turn-off-gnus-message-citation-mode ()
1184   "Turn off `gnus-message-citation-mode'."
1185   (gnus-message-citation-mode -1))
1186
1187 (gnus-ems-redefine)
1188
1189 (provide 'gnus-cite)
1190
1191 ;; Local Variables:
1192 ;; coding: iso-8859-1
1193 ;; End:
1194
1195 ;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
1196 ;;; gnus-cite.el ends here