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