X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-cite.el;h=57fc2816155255c23624b1e8c2e5df8237b0e0e2;hb=851278bf56a0156a4dd5896e9959f63e33d07ee2;hp=bc85ea42be0c7bd1ae22f915f04fd32c1c8f15fd;hpb=73dbcec2454dd5c66eb52ed9faf96add0d1c38ae;p=gnus diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el index bc85ea42b..57fc28161 100644 --- a/lisp/gnus-cite.el +++ b/lisp/gnus-cite.el @@ -1,15 +1,15 @@ ;;; gnus-cite.el --- parse citations in articles for Gnus -;; Copyright (C) 1995,96 Free Software Foundation, Inc. -;; Author: Per Abrahamsen -;; Keywords: news, mail +;; Copyright (C) 1995-2015 Free Software Foundation, Inc. + +;; Author: Per Abhiddenware ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -17,110 +17,350 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: -(require 'gnus) -(require 'gnus-msg) -(require 'gnus-ems) (eval-when-compile (require 'cl)) +(eval-when-compile + (when (featurep 'xemacs) + (require 'easy-mmode))) ; for `define-minor-mode' -(eval-and-compile - (autoload 'gnus-article-add-button "gnus-vis")) +(require 'gnus) +(require 'gnus-range) +(require 'gnus-art) +(require 'message) ; for message-cite-prefix-regexp ;;; Customization: -(defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n" - "Format of cited text buttons.") +(defgroup gnus-cite nil + "Citation." + :prefix "gnus-cite-" + :link '(custom-manual "(gnus)Article Highlighting") + :group 'gnus-article) -(defvar gnus-cited-lines-visible nil - "The number of lines of hidden cited text to remain visible.") +(defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" + "Format of opened cited text buttons." + :group 'gnus-cite + :type 'string) -(defvar gnus-cite-parse-max-size 25000 - "Maximum article size (in bytes) where parsing citations is allowed. -Set it to nil to parse all articles.") +(defcustom gnus-cited-closed-text-button-line-format "%(%{[+]%}%)\n" + "Format of closed cited text buttons." + :group 'gnus-cite + :type 'string) + +(defcustom gnus-cited-lines-visible nil + "The number of lines of hidden cited text to remain visible. +Or a pair (cons) of numbers which are the number of lines at the top +and bottom of the text, respectively, to remain visible." + :group 'gnus-cite + :type '(choice (const :tag "none" nil) + integer + (cons :tag "Top and Bottom" integer integer))) -(defvar gnus-cite-prefix-regexp - "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>" - "Regexp matching the longest possible citation prefix on a line.") +(defcustom gnus-cite-parse-max-size 25000 + "Maximum article size (in bytes) where parsing citations is allowed. +Set it to nil to parse all articles." + :group 'gnus-cite + :type '(choice (const :tag "all" nil) + integer)) -(defvar gnus-cite-max-prefix 20 - "Maximum possible length for a citation prefix.") +(defcustom gnus-cite-max-prefix 20 + "Maximum possible length for a citation prefix." + :group 'gnus-cite + :type 'integer) -(defvar gnus-supercite-regexp - (concat "^\\(" gnus-cite-prefix-regexp "\\)? *" +(defcustom gnus-supercite-regexp + (concat "^\\(" message-cite-prefix-regexp "\\)? *" ">>>>> +\"\\([^\"\n]+\\)\" +==") - "Regexp matching normal Supercite attribution lines. -The first grouping must match prefixes added by other packages.") + "*Regexp matching normal Supercite attribution lines. +The first grouping must match prefixes added by other packages." + :group 'gnus-cite + :type 'regexp) -(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" +(defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" "Regexp matching mangled Supercite attribution lines. -The first regexp group should match the Supercite attribution.") - -(defvar gnus-cite-minimum-match-count 2 - "Minimum number of identical prefixes before we believe it's a citation.") - -;see gnus-cus.el -;(defvar gnus-cite-face-list -; (if (eq gnus-display-type 'color) -; (if (eq gnus-background-mode 'dark) 'light 'dark) -; '(italic)) -; "Faces used for displaying different citations. -;It is either a list of face names, or one of the following special -;values: - -;dark: Create faces from `gnus-face-dark-name-list'. -;light: Create faces from `gnus-face-light-name-list'. - -;The variable `gnus-make-foreground' determines whether the created -;faces change the foreground or the background colors.") - -(defvar gnus-cite-attribution-prefix "in article\\|in <" - "Regexp matching the beginning of an attribution line.") - -(defvar gnus-cite-attribution-suffix - "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$" - "Regexp matching the end of an attribution line. -The text matching the first grouping will be used as a button.") - -;see gnus-cus.el -;(defvar gnus-cite-attribution-face 'underline -; "Face used for attribution lines. -;It is merged with the face for the cited text belonging to the attribution.") - -;see gnus-cus.el -;(defvar gnus-cite-hide-percentage 50 -; "Only hide cited text if it is larger than this percent of the body.") - -;see gnus-cus.el -;(defvar gnus-cite-hide-absolute 10 -; "Only hide cited text if there is at least this number of cited lines.") - -;see gnus-cus.el -;(defvar gnus-face-light-name-list -; '("light blue" "light cyan" "light yellow" "light pink" -; "pale green" "beige" "orange" "magenta" "violet" "medium purple" -; "turquoise") -; "Names of light colors.") - -;see gnus-cus.el -;(defvar gnus-face-dark-name-list -; '("dark salmon" "firebrick" -; "dark green" "dark orange" "dark khaki" "dark violet" -; "dark turquoise") -; "Names of dark colors.") +The first regexp group should match the Supercite attribution." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-minimum-match-count 2 + "Minimum number of identical prefixes before we believe it's a citation." + :group 'gnus-cite + :type 'integer) + +;; Some Microsoft products put in a citation that extends to the +;; remainder of the message: +;; +;; -----Original Message----- +;; From: ... +;; To: ... +;; Sent: ... [date, in non-RFC-2822 format] +;; Subject: ... +;; +;; Cited message, with no prefixes +;; +;; The four headers are always the same. But note they are prone to +;; folding without additional indentation. +;; +;; Others use "----- Original Message -----" instead, and properly quote +;; the body using "> ". This style is handled without special cases. + +(defcustom gnus-cite-attribution-prefix + "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----" + "*Regexp matching the beginning of an attribution line." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-attribution-suffix + "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$" + "*Regexp matching the end of an attribution line. +The text matching the first grouping will be used as a button." + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-unsightly-citation-regexp + "^-----Original Message-----\nFrom: \\(.+\n\\)+\n" + "Regexp matching Microsoft-type rest-of-message citations." + :version "22.1" + :group 'gnus-cite + :type 'regexp) + +(defcustom gnus-cite-ignore-quoted-from t + "Non-nil means don't regard lines beginning with \">From \" as cited text. +Those lines may have been quoted by MTAs in order not to mix up with +the envelope From line." + :version "22.1" + :group 'gnus-cite + :type 'boolean) + +(defface gnus-cite-attribution '((t (:italic t))) + "Face used for attribution lines." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-attribution-face 'face-alias 'gnus-cite-attribution) +(put 'gnus-cite-attribution-face 'obsolete-face "22.1") + +(defcustom gnus-cite-attribution-face 'gnus-cite-attribution + "Face used for attribution lines. +It is merged with the face for the cited text belonging to the attribution." + :version "22.1" + :group 'gnus-cite + :type 'face) + +(defface gnus-cite-1 '((((class color) + (background dark)) + (:foreground "light blue")) + (((class color) + (background light)) + (:foreground "MidnightBlue")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-1 'face-alias 'gnus-cite-1) +(put 'gnus-cite-face-1 'obsolete-face "22.1") + +(defface gnus-cite-2 '((((class color) + (background dark)) + (:foreground "light cyan")) + (((class color) + (background light)) + (:foreground "firebrick")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-2 'face-alias 'gnus-cite-2) +(put 'gnus-cite-face-2 'obsolete-face "22.1") + +(defface gnus-cite-3 '((((class color) + (background dark)) + (:foreground "light yellow")) + (((class color) + (background light)) + (:foreground "dark green")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-3 'face-alias 'gnus-cite-3) +(put 'gnus-cite-face-3 'obsolete-face "22.1") + +(defface gnus-cite-4 '((((class color) + (background dark)) + (:foreground "light pink")) + (((class color) + (background light)) + (:foreground "OrangeRed")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-4 'face-alias 'gnus-cite-4) +(put 'gnus-cite-face-4 'obsolete-face "22.1") + +(defface gnus-cite-5 '((((class color) + (background dark)) + (:foreground "pale green")) + (((class color) + (background light)) + (:foreground "dark khaki")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-5 'face-alias 'gnus-cite-5) +(put 'gnus-cite-face-5 'obsolete-face "22.1") + +(defface gnus-cite-6 '((((class color) + (background dark)) + (:foreground "beige")) + (((class color) + (background light)) + (:foreground "dark violet")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-6 'face-alias 'gnus-cite-6) +(put 'gnus-cite-face-6 'obsolete-face "22.1") + +(defface gnus-cite-7 '((((class color) + (background dark)) + (:foreground "orange")) + (((class color) + (background light)) + (:foreground "SteelBlue4")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-7 'face-alias 'gnus-cite-7) +(put 'gnus-cite-face-7 'obsolete-face "22.1") + +(defface gnus-cite-8 '((((class color) + (background dark)) + (:foreground "magenta")) + (((class color) + (background light)) + (:foreground "magenta")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-8 'face-alias 'gnus-cite-8) +(put 'gnus-cite-face-8 'obsolete-face "22.1") + +(defface gnus-cite-9 '((((class color) + (background dark)) + (:foreground "violet")) + (((class color) + (background light)) + (:foreground "violet")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-9 'face-alias 'gnus-cite-9) +(put 'gnus-cite-face-9 'obsolete-face "22.1") + +(defface gnus-cite-10 '((((class color) + (background dark)) + (:foreground "plum1")) + (((class color) + (background light)) + (:foreground "medium purple")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-10 'face-alias 'gnus-cite-10) +(put 'gnus-cite-face-10 'obsolete-face "22.1") + +(defface gnus-cite-11 '((((class color) + (background dark)) + (:foreground "turquoise")) + (((class color) + (background light)) + (:foreground "turquoise")) + (t + (:italic t))) + "Citation face." + :group 'gnus-cite) +;; backward-compatibility alias +(put 'gnus-cite-face-11 'face-alias 'gnus-cite-11) +(put 'gnus-cite-face-11 'obsolete-face "22.1") + +(defcustom gnus-cite-face-list + '(gnus-cite-1 gnus-cite-2 gnus-cite-3 gnus-cite-4 gnus-cite-5 gnus-cite-6 + gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11) + "*List of faces used for highlighting citations. + +When there are citations from multiple articles in the same message, +Gnus will try to give each citation from each article its own face. +This should make it easier to see who wrote what." + :group 'gnus-cite + :type '(repeat face) + :set (lambda (symbol value) + (prog1 + (custom-set-default symbol value) + (if (boundp 'gnus-message-max-citation-depth) + (setq gnus-message-max-citation-depth (length value))) + (if (boundp 'gnus-message-citation-keywords) + (setq gnus-message-citation-keywords + `((gnus-message-search-citation-line + ,@(let ((list nil) + (count 1)) + (dolist (face value (nreverse list)) + (push (list count (list 'quote face) 'prepend t) + list) + (setq count (1+ count))))))))))) + +(defcustom gnus-cite-hide-percentage 50 + "Only hide excess citation if above this percentage of the body." + :group 'gnus-cite + :type 'number) + +(defcustom gnus-cite-hide-absolute 10 + "Only hide excess citation if above this number of lines in the body." + :group 'gnus-cite + :type 'integer) + +(defcustom gnus-cite-blank-line-after-header t + "If non-nil, put a blank line between the citation header and the button." + :group 'gnus-cite + :type 'boolean) + +;; This has to go here because its default value depends on +;; gnus-cite-face-list. +(defcustom gnus-article-boring-faces (cons 'gnus-signature gnus-cite-face-list) + "List of faces that are not worth reading. +If an article has more pages below the one you are looking at, but +nothing on those pages is a word of at least three letters that is not +in a boring face, then the pages will be skipped." + :type '(repeat face) + :group 'gnus-article-hiding) ;;; Internal Variables: (defvar gnus-cite-article nil) +(defvar gnus-cite-overlay-list nil) (defvar gnus-cite-prefix-alist nil) -;; Alist of citation prefixes. +;; Alist of citation prefixes. ;; The cdr is a list of lines with that prefix. (defvar gnus-cite-attribution-alist nil) @@ -140,36 +380,33 @@ The text matching the first grouping will be used as a button.") ;; PREFIX: Is the citation prefix of the attribution line(s), and ;; TAG: Is a Supercite tag, if any. -(defvar gnus-cited-text-button-line-format-alist - `((?b beg ?d) - (?e end ?d) +(defvar gnus-cited-opened-text-button-line-format-alist + `((?b (marker-position beg) ?d) + (?e (marker-position end) ?d) + (?n (count-lines beg end) ?d) (?l (- end beg) ?d))) -(defvar gnus-cited-text-button-line-format-spec nil) +(defvar gnus-cited-opened-text-button-line-format-spec nil) +(defvar gnus-cited-closed-text-button-line-format-alist + gnus-cited-opened-text-button-line-format-alist) +(defvar gnus-cited-closed-text-button-line-format-spec nil) + ;;; Commands: -(defun gnus-article-highlight-citation (&optional force) +(defun gnus-article-highlight-citation (&optional force same-buffer) "Highlight cited text. Each citation in the article will be highlighted with a different face. The faces are taken from `gnus-cite-face-list'. Attribution lines are highlighted with the same face as the -corresponding citation merged with `gnus-cite-attribution-face'. +corresponding citation merged with the face `gnus-cite-attribution'. Text is considered cited if at least `gnus-cite-minimum-match-count' -lines matches `gnus-cite-prefix-regexp' with the same prefix. +lines matches `message-cite-prefix-regexp' with the same prefix. Lines matching `gnus-cite-attribution-suffix' and perhaps `gnus-cite-attribution-prefix' are considered attribution lines." (interactive (list 'force)) - ;; Create dark or light faces if necessary. - (cond ((eq gnus-cite-face-list 'light) - (setq gnus-cite-face-list - (mapcar 'gnus-make-face gnus-face-light-name-list))) - ((eq gnus-cite-face-list 'dark) - (setq gnus-cite-face-list - (mapcar 'gnus-make-face gnus-face-dark-name-list)))) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer (if same-buffer (current-buffer) gnus-article-buffer) (gnus-cite-parse-maybe force) (let ((buffer-read-only nil) (alist gnus-cite-prefix-alist) @@ -201,12 +438,13 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps skip (gnus-cite-find-prefix number) face (cdr (assoc prefix face-alist))) ;; Add attribution button. - (goto-line number) - (if (re-search-forward gnus-cite-attribution-suffix - (save-excursion (end-of-line 1) (point)) - t) - (gnus-article-add-button (match-beginning 1) (match-end 1) - 'gnus-cite-toggle prefix)) + (goto-char (point-min)) + (forward-line (1- number)) + (when (re-search-forward gnus-cite-attribution-suffix + (point-at-eol) + t) + (gnus-article-add-button (match-beginning 1) (match-end 1) + 'gnus-cite-toggle prefix)) ;; Highlight attribution line. (gnus-cite-add-face number skip face) (gnus-cite-add-face number skip gnus-cite-attribution-face)) @@ -221,9 +459,8 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (defun gnus-dissect-cited-text () "Dissect the article buffer looking for cited text." - (save-excursion - (set-buffer gnus-article-buffer) - (gnus-cite-parse-maybe) + (with-current-buffer gnus-article-buffer + (gnus-cite-parse-maybe nil t) (let ((alist gnus-cite-prefix-alist) prefix numbers number marks m) ;; Loop through citation prefixes. @@ -241,14 +478,16 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (goto-char (point-min)) (forward-line (1- number)) (push (cons (point-marker) prefix) marks))) - (goto-char (point-min)) - (search-forward "\n\n" nil t) + ;; Skip to the beginning of the body. + (article-goto-body) (push (cons (point-marker) "") marks) + ;; Find the end of the body. (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) + (gnus-article-search-signature) (push (cons (point-marker) "") marks) - (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2))))) - (let* ((omarks marks)) + ;; Sort the marks. + (setq marks (sort marks 'car-less-than-car)) + (let ((omarks marks)) (setq marks nil) (while (cdr omarks) (if (= (caar omarks) (caadr omarks)) @@ -257,7 +496,10 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (push (car omarks) marks)) (unless (equal (cdadr omarks) "") (push (cadr omarks) marks)) - (setq omarks (cdr omarks))) + (unless (and (equal (cdar omarks) "") + (equal (cdadr omarks) "") + (not (cddr omarks))) + (setq omarks (cdr omarks)))) (push (car omarks) marks)) (setq omarks (cdr omarks))) (when (car omarks) @@ -267,91 +509,215 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (if (and (equal (cdadr m) "") (equal (cdar m) (cdaddr m)) (goto-char (caadr m)) + (looking-at "[ \t]*$") (forward-line 1) (= (point) (caaddr m))) (setcdr m (cdddr m)) (setq m (cdr m)))) marks)))) - -(defun gnus-article-fill-cited-article (&optional force) - "Do word wrapping in the current article." - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) +(defun gnus-article-fill-cited-long-lines () + (gnus-article-fill-cited-article nil t)) + +(defun gnus-article-fill-cited-article (&optional width long-lines) + "Do word wrapping in the current article. +If WIDTH (the numerical prefix), use that text width when +filling. If LONG-LINES, only fill sections that have lines +longer than the frame width." + (interactive "P") + (with-current-buffer gnus-article-buffer (let ((buffer-read-only nil) (inhibit-point-motion-hooks t) (marks (gnus-dissect-cited-text)) - (adaptive-fill-mode nil)) + (adaptive-fill-mode nil) + (filladapt-mode nil) + (fill-column (if width (prefix-numeric-value width) fill-column))) (save-restriction (while (cdr marks) - (widen) (narrow-to-region (caar marks) (caadr marks)) (let ((adaptive-fill-regexp (concat "^" (regexp-quote (cdar marks)) " *")) - (fill-prefix (cdar marks))) - (fill-region (point-min) (point-max))) + (fill-prefix + (if (string= (cdar marks) "") "" + (concat (cdar marks) " "))) + (do-fill (not long-lines)) + use-hard-newlines) + (unless do-fill + (setq do-fill (gnus-article-foldable-buffer (cdar marks)))) + ;; Note: the XEmacs version of `fill-region' inserts a newline + ;; unless the region ends with a newline. + (when do-fill + (if (not long-lines) + (fill-region (point-min) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (when (prog1 + (> (current-column) (window-width)) + (forward-line 1)) + (save-restriction + (narrow-to-region (line-beginning-position 0) (point)) + (fill-region (point-min) (point-max)))))))) (set-marker (caar marks) nil) (setq marks (cdr marks))) (when marks - (set-marker (caar marks) nil)))))) + (set-marker (caar marks) nil)) + ;; All this information is now incorrect. + (setq gnus-cite-prefix-alist nil + gnus-cite-attribution-alist nil + gnus-cite-loose-prefix-alist nil + gnus-cite-loose-attribution-alist nil + gnus-cite-article nil))))) + +(defun gnus-article-foldable-buffer (prefix) + (let ((do-fill nil) + columns) + (goto-char (point-min)) + (while (not (eobp)) + (unless (> (length prefix) (- (point-max) (point))) + (forward-char (length prefix))) + (skip-chars-forward " \t") + (unless (eolp) + (let ((elem (assq (current-column) columns))) + (unless elem + (setq elem (cons (current-column) 0)) + (push elem columns)) + (setcdr elem (1+ (cdr elem))))) + (end-of-line) + (when (> (current-column) (window-width)) + (setq do-fill t)) + (forward-line 1)) + (and do-fill + ;; We know know that there are long lines here, but does this look + ;; like code? Check for ragged edges on the left. + (< (length columns) 3)))) (defun gnus-article-hide-citation (&optional arg force) "Toggle hiding of all cited text except attribution lines. See the documentation for `gnus-article-highlight-citation'. If given a negative prefix, always show; if given a positive prefix, always hide." - (interactive (append (gnus-hidden-arg) (list 'force))) - (setq gnus-cited-text-button-line-format-spec - (gnus-parse-format gnus-cited-text-button-line-format - gnus-cited-text-button-line-format-alist t)) - (unless (gnus-article-check-hidden-text 'cite arg) - (save-excursion - (set-buffer gnus-article-buffer) - (let ((buffer-read-only nil) - (marks (gnus-dissect-cited-text)) - (inhibit-point-motion-hooks t) - (props (nconc (list 'gnus-type 'cite) - gnus-hidden-properties)) - beg end) - (while marks - (setq beg nil - end nil) - (while (and marks (string= (cdar marks) "")) - (setq marks (cdr marks))) - (when marks - (setq beg (caar marks))) - (while (and marks (not (string= (cdar marks) ""))) - (setq marks (cdr marks))) - (when marks + (interactive (append (gnus-article-hidden-arg) (list 'force))) + (gnus-set-format 'cited-opened-text-button t) + (gnus-set-format 'cited-closed-text-button t) + (with-current-buffer gnus-article-buffer + (let ((buffer-read-only nil) + marks + (inhibit-point-motion-hooks t) + (props (nconc (list 'article-type 'cite) + gnus-hidden-properties)) + (point (point-min)) + found beg end start) + (while (setq point + (text-property-any point (point-max) + 'gnus-callback + 'gnus-article-toggle-cited-text)) + (setq found t) + (goto-char point) + (gnus-article-toggle-cited-text + (get-text-property point 'gnus-data) arg) + (forward-line 1) + (setq point (point))) + (unless found + (setq marks (gnus-dissect-cited-text)) + (while marks + (setq beg nil + end nil) + (while (and marks (string= (cdar marks) "")) + (setq marks (cdr marks))) + (when marks + (setq beg (caar marks))) + (while (and marks (not (string= (cdar marks) ""))) + (setq marks (cdr marks))) + (when marks (setq end (caar marks))) - ;; Skip past lines we want to leave visible. - (when (and beg end gnus-cited-lines-visible) - (goto-char beg) - (forward-line gnus-cited-lines-visible) - (if (>= (point) end) - (setq beg nil) - (setq beg (point-marker)))) - (when (and beg end) - (gnus-add-text-properties beg end props) - (goto-char beg) - (unless (save-excursion (search-backward "\n\n" nil t)) - (insert "\n")) - (gnus-article-add-button - (point) - (progn (eval gnus-cited-text-button-line-format-spec) (point)) - `gnus-article-toggle-cited-text (cons beg end)) - (set-marker beg (point)))))))) - -(defun gnus-article-toggle-cited-text (region) - "Toggle hiding the text in REGION." - (let (buffer-read-only) - (funcall - (if (text-property-any - (car region) (1- (cdr region)) - (car gnus-hidden-properties) (cadr gnus-hidden-properties)) - 'remove-text-properties 'gnus-add-text-properties) - (car region) (cdr region) gnus-hidden-properties))) + ;; Skip past lines we want to leave visible. + (when (and beg end gnus-cited-lines-visible) + (goto-char beg) + (forward-line (if (consp gnus-cited-lines-visible) + (car gnus-cited-lines-visible) + gnus-cited-lines-visible)) + (if (>= (point) end) + (setq beg nil) + (setq beg (point-marker)) + (when (consp gnus-cited-lines-visible) + (goto-char end) + (forward-line (- (cdr gnus-cited-lines-visible))) + (if (<= (point) beg) + (setq beg nil) + (setq end (point-marker)))))) + (when (and beg end) + (gnus-add-wash-type 'cite) + ;; We use markers for the end-points to facilitate later + ;; wrapping and mangling of text. + (setq beg (set-marker (make-marker) beg) + end (set-marker (make-marker) end)) + (gnus-add-text-properties-when 'article-type nil beg end props) + (goto-char beg) + (when (and gnus-cite-blank-line-after-header + (not (save-excursion (search-backward "\n\n" nil t)))) + (insert "\n")) + (put-text-property + (setq start (point-marker)) + (progn + (gnus-article-add-button + (point) + (progn (eval gnus-cited-closed-text-button-line-format-spec) + (point)) + `gnus-article-toggle-cited-text + (list (cons beg end) start)) + (point)) + 'article-type 'annotation) + (set-marker beg (point)))))))) + +(defun gnus-article-toggle-cited-text (args &optional arg) + "Toggle hiding the text in REGION. +ARG can be nil or a number. Positive means hide, negative +means show, nil means toggle." + (let* ((region (car args)) + (beg (car region)) + (end (cdr region)) + (start (cadr args)) + (hidden + (text-property-any beg (1- end) 'article-type 'cite)) + (inhibit-point-motion-hooks t) + buffer-read-only) + (when (or (null arg) + (zerop arg) + (and (> arg 0) (not hidden)) + (and (< arg 0) hidden)) + (if hidden + (progn + ;; Can't remove 'cite from g-a-wash-types here because + ;; multiple citations may be hidden -jas + (gnus-remove-text-properties-when + 'article-type 'cite beg end + (cons 'article-type (cons 'cite + gnus-hidden-properties)))) + (gnus-add-wash-type 'cite) + (gnus-add-text-properties-when + 'article-type nil beg end + (cons 'article-type (cons 'cite + gnus-hidden-properties)))) + (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)) + (save-excursion + (goto-char start) + (gnus-delete-line) + (put-text-property + (point) + (progn + (gnus-article-add-button + (point) + (progn (eval + (if hidden + gnus-cited-opened-text-button-line-format-spec + gnus-cited-closed-text-button-line-format-spec)) + (point)) + `gnus-article-toggle-cited-text + args) + (point)) + 'article-type 'annotation))))) (defun gnus-article-hide-citation-maybe (&optional arg force) "Toggle hiding of cited text that has an attribution line. @@ -362,120 +728,155 @@ percent and at least `gnus-cite-hide-absolute' lines of the body is cited text with attributions. When called interactively, these two variables are ignored. See also the documentation for `gnus-article-highlight-citation'." - (interactive (append (gnus-hidden-arg) (list 'force))) - (unless (gnus-article-check-hidden-text 'cite arg) - (save-excursion - (set-buffer gnus-article-buffer) - (gnus-cite-parse-maybe force) - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (let ((start (point)) - (atts gnus-cite-attribution-alist) - (buffer-read-only nil) - (inhibit-point-motion-hooks t) - (hiden 0) - total) - (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) - (setq total (count-lines start (point))) - (while atts - (setq hiden (+ hiden (length (cdr (assoc (cdar atts) - gnus-cite-prefix-alist)))) - atts (cdr atts))) - (if (or force - (and (> (* 100 hiden) (* gnus-cite-hide-percentage total)) - (> hiden gnus-cite-hide-absolute))) - (progn - (setq atts gnus-cite-attribution-alist) - (while atts - (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) - atts (cdr atts)) - (while total - (setq hiden (car total) - total (cdr total)) - (goto-line hiden) - (or (assq hiden gnus-cite-attribution-alist) - (gnus-add-text-properties - (point) (progn (forward-line 1) (point)) - (nconc (list 'gnus-type 'cite) - gnus-hidden-properties))))))))))) + (interactive (append (gnus-article-hidden-arg) '(force))) + (with-current-buffer gnus-article-buffer + (gnus-delete-wash-type 'cite) + (unless (gnus-article-check-hidden-text 'cite arg) + (save-excursion + (gnus-cite-parse-maybe force) + (article-goto-body) + (let ((start (point)) + (atts gnus-cite-attribution-alist) + (buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hidden 0) + total) + (goto-char (point-max)) + (gnus-article-search-signature) + (setq total (count-lines start (point))) + (while atts + (setq hidden (+ hidden (length + (cdr (assoc (cdar atts) + gnus-cite-prefix-alist)))) + atts (cdr atts))) + (when (or force + (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) + (> hidden gnus-cite-hide-absolute))) + (gnus-article-hide-citation))))))) (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." (interactive) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (let ((article (cdr gnus-article-current))) - (unless (save-excursion - (set-buffer gnus-summary-buffer) + (unless (with-current-buffer gnus-summary-buffer (gnus-article-displayed-root-p article)) (gnus-article-hide-citation))))) ;;; Internal functions: -(defun gnus-cite-parse-maybe (&optional force) - ;; Parse if the buffer has changes since last time. - (if (equal gnus-cite-article gnus-article-current) +(defun gnus-cite-parse-maybe (&optional force no-overlay) + "Always parse the buffer." + (gnus-cite-localize) + ;;Reset parser information. + (setq gnus-cite-prefix-alist nil + gnus-cite-attribution-alist nil + gnus-cite-loose-prefix-alist nil + gnus-cite-loose-attribution-alist nil) + (unless no-overlay + (gnus-cite-delete-overlays)) + ;; Parse if not too large. + (if (and gnus-cite-parse-max-size + (> (buffer-size) gnus-cite-parse-max-size)) () - ;;Reset parser information. - (setq gnus-cite-prefix-alist nil - gnus-cite-attribution-alist nil - gnus-cite-loose-prefix-alist nil - gnus-cite-loose-attribution-alist nil) - ;; Parse if not too large. - (if (and (not force) - gnus-cite-parse-max-size - (> (buffer-size) gnus-cite-parse-max-size)) - () - (setq gnus-cite-article (cons (car gnus-article-current) - (cdr gnus-article-current))) - (gnus-cite-parse)))) + (setq gnus-cite-article (cons (car gnus-article-current) + (cdr gnus-article-current))) + (gnus-cite-parse-wrapper))) + +(defun gnus-cite-delete-overlays () + (dolist (overlay gnus-cite-overlay-list) + (ignore-errors + (when (or (not (overlay-end overlay)) + (and (>= (overlay-end overlay) (point-min)) + (<= (overlay-end overlay) (point-max)))) + (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) + (ignore-errors + (delete-overlay overlay)))))) + +(defun gnus-cite-parse-wrapper () + ;; Wrap chopped gnus-cite-parse. + (article-goto-body) + (let ((inhibit-point-motion-hooks t)) + (save-excursion + (gnus-cite-parse-attributions)) + (save-excursion + (gnus-cite-parse)) + (save-excursion + (gnus-cite-connect-attributions)))) (defun gnus-cite-parse () ;; Parse and connect citation prefixes and attribution lines. - + ;; Parse current buffer searching for citation prefixes. - (goto-char (point-min)) - (or (search-forward "\n\n" nil t) - (goto-char (point-max))) (let ((line (1+ (count-lines (point-min) (point)))) (case-fold-search t) (max (save-excursion (goto-char (point-max)) - (re-search-backward gnus-signature-separator nil t) + (gnus-article-search-signature) (point))) - alist entry start begin end numbers prefix) + (prefix-regexp (concat "^\\(" message-cite-prefix-regexp "\\)")) + alist entry start begin end numbers prefix guess-limit) ;; Get all potential prefixes in `alist'. (while (< (point) max) ;; Each line. (setq begin (point) - end (progn (beginning-of-line 2) (point)) + guess-limit (progn (skip-chars-forward "^> \t\r\n") (point)) + end (point-at-bol 2) start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. - (if (looking-at gnus-supercite-regexp) - (if (match-end 1) - (setq end (1+ (match-end 1))) - (setq end (1+ begin)))) + (when (and (< guess-limit (+ begin gnus-cite-max-prefix)) + (looking-at gnus-supercite-regexp)) + (if (match-end 1) + (setq end (1+ (match-end 1))) + (setq end (1+ begin)))) ;; Ignore very long prefixes. - (if (> end (+ (point) gnus-cite-max-prefix)) - (setq end (+ (point) gnus-cite-max-prefix))) - (while (re-search-forward gnus-cite-prefix-regexp (1- end) t) + (when (> end (+ begin gnus-cite-max-prefix)) + (setq end (+ begin gnus-cite-max-prefix))) + ;; Ignore quoted envelope From_. + (when (and gnus-cite-ignore-quoted-from + (prog2 + (setq case-fold-search nil) + (looking-at ">From ") + (setq case-fold-search t))) + (setq end (1+ begin))) + (while (re-search-forward prefix-regexp (1- end) t) ;; Each prefix. (setq end (match-end 0) prefix (buffer-substring begin end)) - (gnus-set-text-properties 0 (length prefix) nil prefix) + (set-text-properties 0 (length prefix) nil prefix) (setq entry (assoc prefix alist)) - (if entry + (if entry (setcdr entry (cons line (cdr entry))) - (setq alist (cons (list prefix line) alist))) + (push (list prefix line) alist)) (goto-char begin)) (goto-char start) (setq line (1+ line))) + ;; Horrible special case for some Microsoft mailers. + (goto-char (point-min)) + (setq start t begin nil entry nil) + (while start + ;; Assume this search ends up at the beginning of a line. + (if (re-search-forward gnus-cite-unsightly-citation-regexp max t) + (progn + (when (number-or-marker-p start) + (setq begin (count-lines (point-min) start) + end (count-lines (point-min) (match-beginning 0)))) + (setq start (match-end 0))) + (when (number-or-marker-p start) + (setq begin (count-lines (point-min) start) + end (count-lines (point-min) max))) + (setq start nil)) + (when begin + (while (< begin end) + ;; Need to do 1+ because we're in the bol. + (push (setq begin (1+ begin)) entry)))) + (when entry + (push (cons "" entry) alist)) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each - ;; line that appears at least gnus-cite-minimum-match-count - ;; times. First sort them by length. Longer is older. + ;; line that appears at least `gnus-cite-minimum-match-count' + ;; times. First sort them by length. Longer is older. (setq alist (sort alist (lambda (a b) (> (length (car a)) (length (car b)))))) (while alist @@ -491,72 +892,84 @@ See also the documentation for `gnus-article-highlight-citation'." ;; Too few lines with this prefix. We keep it a bit ;; longer in case it is an exact match for an attribution ;; line, but we don't remove the line from other - ;; prefixes. - (setq gnus-cite-prefix-alist - (cons entry gnus-cite-prefix-alist))) + ;; prefixes. + (push entry gnus-cite-prefix-alist)) (t - (setq gnus-cite-prefix-alist (cons entry - gnus-cite-prefix-alist)) + (push entry + gnus-cite-prefix-alist) ;; Remove articles from other prefixes. (let ((loop alist) current) (while loop (setq current (car loop) loop (cdr loop)) - (setcdr current - (gnus-set-difference (cdr current) numbers)))))))) + (setcdr current + (gnus-set-difference (cdr current) numbers))))))))) + +(defun gnus-cite-parse-attributions () + (let (al-alist) + ;; Parse attributions + (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (wrote (count-lines (point-min) end)) + (prefix (gnus-cite-find-prefix wrote)) + ;; Check previous line for an attribution leader. + (tag (progn + (beginning-of-line 1) + (when (looking-at gnus-supercite-secondary-regexp) + (buffer-substring (match-beginning 1) + (match-end 1))))) + (in (progn + (goto-char start) + (and (re-search-backward gnus-cite-attribution-prefix + (save-excursion + (beginning-of-line 0) + (point)) + t) + (not (re-search-forward gnus-cite-attribution-suffix + start t)) + (count-lines (point-min) (1+ (point))))))) + (when (eq wrote in) + (setq in nil)) + (goto-char end) + ;; don't add duplicates + (let ((al (buffer-substring (save-excursion (beginning-of-line 0) + (1+ (point))) + end))) + (when (not (assoc al al-alist)) + (push (list wrote in prefix tag) + gnus-cite-loose-attribution-alist) + (push (cons al t) al-alist))))))) + +(defun gnus-cite-connect-attributions () + ;; Connect attributions to citations + ;; No citations have been connected to attribution lines yet. (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil)) ;; Parse current buffer searching for attribution lines. - (goto-char (point-min)) - (search-forward "\n\n" nil t) - (while (re-search-forward gnus-cite-attribution-suffix (point-max) t) - (let* ((start (match-beginning 0)) - (end (match-end 0)) - (wrote (count-lines (point-min) end)) - (prefix (gnus-cite-find-prefix wrote)) - ;; Check previous line for an attribution leader. - (tag (progn - (beginning-of-line 1) - (and (looking-at gnus-supercite-secondary-regexp) - (buffer-substring (match-beginning 1) - (match-end 1))))) - (in (progn - (goto-char start) - (and (re-search-backward gnus-cite-attribution-prefix - (save-excursion - (beginning-of-line 0) - (point)) - t) - (not (re-search-forward gnus-cite-attribution-suffix - start t)) - (count-lines (point-min) (1+ (point))))))) - (if (eq wrote in) - (setq in nil)) - (goto-char end) - (setq gnus-cite-loose-attribution-alist - (cons (list wrote in prefix tag) - gnus-cite-loose-attribution-alist)))) ;; Find exact supercite citations. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) - (if tag - (concat "\\`" - (regexp-quote prefix) "[ \t]*" - (regexp-quote tag) ">")))) + (when tag + (concat "\\`" + (regexp-quote prefix) "[ \t]*" + (regexp-quote tag) ">")))) ;; Find loose supercite citations after attributions. (gnus-cite-match-attributions 'small t (lambda (prefix tag) - (if tag (concat "\\<" - (regexp-quote tag) - "\\>")))) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) ;; Find loose supercite citations anywhere. (gnus-cite-match-attributions 'small nil (lambda (prefix tag) - (if tag (concat "\\<" - (regexp-quote tag) - "\\>")))) + (when tag + (concat "\\<" + (regexp-quote tag) + "\\>")))) ;; Find nested citations after attributions. (gnus-cite-match-attributions 'small-if-unique t (lambda (prefix tag) @@ -571,11 +984,11 @@ See also the documentation for `gnus-article-highlight-citation'." (while alist (setq entry (car alist) alist (cdr alist)) - (if (< (length (cdr entry)) gnus-cite-minimum-match-count) - (setq gnus-cite-prefix-alist - (delq entry gnus-cite-prefix-alist) - gnus-cite-loose-prefix-alist - (delq entry gnus-cite-loose-prefix-alist))))) + (when (< (length (cdr entry)) gnus-cite-minimum-match-count) + (setq gnus-cite-prefix-alist + (delq entry gnus-cite-prefix-alist) + gnus-cite-loose-prefix-alist + (delq entry gnus-cite-loose-prefix-alist))))) ;; Find flat attributions. (gnus-cite-match-attributions 'first t nil) ;; Find any attributions (are we getting desperate yet?). @@ -596,8 +1009,8 @@ See also the documentation for `gnus-article-highlight-citation'." ;; If FUN is non-nil, it will be called with the arguments (WROTE ;; PREFIX TAG) and expected to return a regular expression. Only ;; citations whose prefix matches the regular expression will be - ;; considered. - ;; + ;; considered. + ;; ;; WROTE is the attribution line number. ;; PREFIX is the attribution line prefix. ;; TAG is the Supercite tag on the attribution line. @@ -616,7 +1029,7 @@ See also the documentation for `gnus-article-highlight-citation'." ((eq sort 'first) nil) (t (< (length (gnus-cite-find-loose prefix)) 2))) limit (if after wrote -1) - smallest 1000000 + smallest 1000000 best nil) (let ((cites gnus-cite-loose-prefix-alist) cite candidate numbers first compare) @@ -637,27 +1050,25 @@ See also the documentation for `gnus-article-highlight-citation'." () (setq gnus-cite-loose-attribution-alist (delq att gnus-cite-loose-attribution-alist)) - (setq gnus-cite-attribution-alist - (cons (cons wrote (car best)) gnus-cite-attribution-alist)) - (if in - (setq gnus-cite-attribution-alist - (cons (cons in (car best)) gnus-cite-attribution-alist))) - (if (memq best gnus-cite-loose-prefix-alist) - (let ((loop gnus-cite-prefix-alist) - (numbers (cdr best)) - current) - (setq gnus-cite-loose-prefix-alist - (delq best gnus-cite-loose-prefix-alist)) - (while loop - (setq current (car loop) - loop (cdr loop)) - (if (eq current best) - () - (setcdr current (gnus-set-difference (cdr current) numbers)) - (if (null (cdr current)) - (setq gnus-cite-loose-prefix-alist - (delq current gnus-cite-loose-prefix-alist) - atts (delq current atts))))))))))) + (push (cons wrote (car best)) gnus-cite-attribution-alist) + (when in + (push (cons in (car best)) gnus-cite-attribution-alist)) + (when (memq best gnus-cite-loose-prefix-alist) + (let ((loop gnus-cite-prefix-alist) + (numbers (cdr best)) + current) + (setq gnus-cite-loose-prefix-alist + (delq best gnus-cite-loose-prefix-alist)) + (while loop + (setq current (car loop) + loop (cdr loop)) + (if (eq current best) + () + (setcdr current (gnus-set-difference (cdr current) numbers)) + (when (null (cdr current)) + (setq gnus-cite-loose-prefix-alist + (delq current gnus-cite-loose-prefix-alist) + atts (delq current atts))))))))))) (defun gnus-cite-find-loose (prefix) ;; Return a list of loose attribution lines prefixed by PREFIX. @@ -667,17 +1078,17 @@ See also the documentation for `gnus-article-highlight-citation'." (setq att (car atts) line (car att) atts (cdr atts)) - (if (string-equal (gnus-cite-find-prefix line) prefix) - (setq lines (cons line lines)))) + (when (string-equal (gnus-cite-find-prefix line) prefix) + (push line lines))) lines)) (defun gnus-cite-add-face (number prefix face) ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line. (when face (let ((inhibit-point-motion-hooks t) - from to) - (goto-line number) - (unless (eobp) ;; Sometimes things become confused. + from to overlay) + (goto-char (point-min)) + (when (zerop (forward-line (1- number))) (forward-char (length prefix)) (skip-chars-forward " \t") (setq from (point)) @@ -685,11 +1096,14 @@ See also the documentation for `gnus-article-highlight-citation'." (skip-chars-backward " \t") (setq to (point)) (when (< from to) - (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))) + (push (setq overlay (make-overlay from to nil t)) + gnus-cite-overlay-list) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'face face)))))) (defun gnus-cite-toggle (prefix) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer + (gnus-cite-parse-maybe nil t) (let ((buffer-read-only nil) (numbers (cdr (assoc prefix gnus-cite-prefix-alist))) (inhibit-point-motion-hooks t) @@ -697,16 +1111,23 @@ See also the documentation for `gnus-article-highlight-citation'." (while numbers (setq number (car numbers) numbers (cdr numbers)) - (goto-line number) + (goto-char (point-min)) + (forward-line (1- number)) (cond ((get-text-property (point) 'invisible) + ;; Can't remove 'cite from g-a-wash-types here because + ;; multiple citations may be hidden -jas (remove-text-properties (point) (progn (forward-line 1) (point)) gnus-hidden-properties)) ((assq number gnus-cite-attribution-alist)) (t - (gnus-add-text-properties + (gnus-add-wash-type 'cite) + (gnus-add-text-properties (point) (progn (forward-line 1) (point)) - (nconc (list 'gnus-type 'cite) - gnus-hidden-properties)))))))) + (nconc (list 'article-type 'cite) + gnus-hidden-properties)))) + (let ((gnus-article-mime-handle-alist-1 + gnus-article-mime-handle-alist)) + (gnus-set-mode-line 'article)))))) (defun gnus-cite-find-prefix (line) ;; Return citation prefix for LINE. @@ -716,17 +1137,123 @@ See also the documentation for `gnus-article-highlight-citation'." (while alist (setq entry (car alist) alist (cdr alist)) - (if (memq line (cdr entry)) - (setq prefix (car entry)))) + (when (memq line (cdr entry)) + (setq prefix (car entry)))) prefix)) -(gnus-add-shutdown 'gnus-cache-close 'gnus) +(defun gnus-cite-localize () + "Make the citation variables local to the article buffer." + (let ((vars '(gnus-cite-article + gnus-cite-overlay-list gnus-cite-prefix-alist + gnus-cite-attribution-alist gnus-cite-loose-prefix-alist + gnus-cite-loose-attribution-alist))) + (while vars + (make-local-variable (pop vars))))) + +;; Highlighting of different citation levels in message-mode. +;; - message-cite-prefix will be overridden if this is enabled. + +(defvar gnus-message-max-citation-depth + (length gnus-cite-face-list) + "Maximum supported level of citation.") -(defun gnus-cache-close () - (setq gnus-cite-prefix-alist nil)) +(defvar gnus-message-cite-prefix-regexp + (concat "^\\(?:" message-cite-prefix-regexp "\\)")) + +(defun gnus-message-search-citation-line (limit) + "Search for a cited line and set match data accordingly. +Returns nil if there is no such line before LIMIT, t otherwise." + (when (re-search-forward gnus-message-cite-prefix-regexp limit t) + (let ((cdepth (min (length (apply 'concat + (split-string + (match-string-no-properties 0) + "[ \t [:alnum:]]+"))) + gnus-message-max-citation-depth)) + (mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil)) + (start (point-at-bol)) + (end (point-at-eol))) + (setcar mlist start) + (setcar (cdr mlist) end) + (setcar (nthcdr (* cdepth 2) mlist) start) + (setcar (nthcdr (1+ (* cdepth 2)) mlist) end) + (set-match-data mlist)) + t)) + +(defvar gnus-message-citation-keywords + ;; eval-when-compile ;; This breaks in XEmacs + `((gnus-message-search-citation-line + ,@(let ((list nil) + (count 1)) + ;; (require 'gnus-cite) + (dolist (face gnus-cite-face-list (nreverse list)) + (push (list count (list 'quote face) 'prepend t) list) + (setq count (1+ count)))))) ;; + "Keywords for highlighting different levels of message citations.") + +(defvar font-lock-defaults-computed) +(defvar font-lock-keywords) +(defvar font-lock-set-defaults) + +(eval-and-compile + (unless (featurep 'xemacs) + (autoload 'font-lock-set-defaults "font-lock"))) + +(define-minor-mode gnus-message-citation-mode + "Minor mode providing more font-lock support for nested citations. +When enabled, it automatically turns on `font-lock-mode'." + nil ;; init-value + "" ;; lighter + nil ;; keymap + (when (eq major-mode 'message-mode) ;FIXME: Use derived-mode-p. + ;; FIXME: Use font-lock-add-keywords! + (let ((defaults (car (if (featurep 'xemacs) + (get 'message-mode 'font-lock-defaults) + font-lock-defaults))) + default keywords) + (while defaults + (setq default (if (consp defaults) + (pop defaults) + (prog1 + defaults + (setq defaults nil)))) + (if gnus-message-citation-mode + ;; `gnus-message-citation-keywords' should be the last + ;; elements of the keywords because the others are unlikely + ;; to have the OVERRIDE flags -- XEmacs applies a keyword + ;; having no OVERRIDE flag to matched text even if it has + ;; already other faces, while Emacs doesn't. + (set (make-local-variable default) + (append (default-value default) + gnus-message-citation-keywords)) + (kill-local-variable default)))) + ;; Force `font-lock-set-defaults' to update `font-lock-keywords'. + (if (featurep 'xemacs) + (progn + (require 'font-lock) + (setq font-lock-defaults-computed nil + font-lock-keywords nil)) + (setq font-lock-set-defaults nil)) + (font-lock-set-defaults) + (cond (font-lock-mode + (if (fboundp 'font-lock-flush) + (font-lock-flush) + (font-lock-fontify-buffer))) + (gnus-message-citation-mode + (font-lock-mode 1))))) + +(defun turn-on-gnus-message-citation-mode () + "Turn on `gnus-message-citation-mode'." + (gnus-message-citation-mode 1)) +(defun turn-off-gnus-message-citation-mode () + "Turn off `gnus-message-citation-mode'." + (gnus-message-citation-mode -1)) (gnus-ems-redefine) (provide 'gnus-cite) +;; Local Variables: +;; coding: utf-8 +;; End: + ;;; gnus-cite.el ends here