;;; gnus-cite.el --- parse citations in articles for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Per Abhiddenware
;; 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.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile
+ (when (featurep 'xemacs)
+ (require 'easy-mmode))) ; for `define-minor-mode'
(require 'gnus)
(require 'gnus-range)
(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)
-(defface gnus-cite-attribution-face '((t
- (:italic t)))
- "Face used for attribution lines.")
+(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)
-(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
+(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)
+
+(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-face-1 '((((class color)
- (background dark))
- (:foreground "light blue"))
- (((class color)
- (background light))
- (:foreground "MidnightBlue"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-2 '((((class color)
- (background dark))
- (:foreground "light cyan"))
- (((class color)
- (background light))
- (:foreground "firebrick"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-3 '((((class color)
- (background dark))
- (:foreground "light yellow"))
- (((class color)
- (background light))
- (:foreground "dark green"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-4 '((((class color)
- (background dark))
- (:foreground "light pink"))
- (((class color)
- (background light))
- (:foreground "OrangeRed"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-5 '((((class color)
- (background dark))
- (:foreground "pale green"))
- (((class color)
- (background light))
- (:foreground "dark khaki"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-6 '((((class color)
- (background dark))
- (:foreground "beige"))
- (((class color)
- (background light))
- (:foreground "dark violet"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-7 '((((class color)
- (background dark))
- (:foreground "orange"))
- (((class color)
- (background light))
- (:foreground "SteelBlue4"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-8 '((((class color)
- (background dark))
- (:foreground "magenta"))
- (((class color)
- (background light))
- (:foreground "magenta"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-9 '((((class color)
- (background dark))
- (:foreground "violet"))
- (((class color)
- (background light))
- (:foreground "violet"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-10 '((((class color)
- (background dark))
- (:foreground "medium purple"))
- (((class color)
- (background light))
- (:foreground "medium purple"))
- (t
- (:italic t)))
- "Citation face.")
-
-(defface gnus-cite-face-11 '((((class color)
- (background dark))
- (:foreground "turquoise"))
- (((class color)
- (background light))
- (:foreground "turquoise"))
- (t
- (:italic t)))
- "Citation 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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(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)
+
+(defface gnus-cite-10 '((((class color)
+ (background dark))
+ (:foreground "medium purple"))
+ (((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)
+
+(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)
(defcustom gnus-cite-face-list
- '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4
- gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
- gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
+ '(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,
;; This has to go here because its default value depends on
;; gnus-cite-face-list.
-(defcustom gnus-article-boring-faces (cons 'gnus-signature-face
- 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
;;; Commands:
-(defun gnus-article-highlight-citation (&optional force)
+(defun gnus-article-highlight-citation (&optional force keep-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 `message-cite-prefix-regexp' with the same prefix.
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
(save-excursion
- (set-buffer gnus-article-buffer)
+ (unless keep-buffer
+ (set-buffer gnus-article-buffer))
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
(goto-char (point-min))
(forward-line (1- number))
(when (re-search-forward gnus-cite-attribution-suffix
- (gnus-point-at-eol)
+ (point-at-eol)
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
'gnus-cite-toggle prefix))
variables are ignored.
See also the documentation for `gnus-article-highlight-citation'."
(interactive (append (gnus-article-hidden-arg) '(force)))
- (unless (gnus-article-check-hidden-text 'cite arg)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (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)))
- (setq atts gnus-cite-attribution-alist)
+ (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 total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
- atts (cdr atts))
- (while total
- (setq hidden (car total)
- total (cdr total))
- (goto-char (point-min))
- (forward-line (1- hidden))
- (unless (assq hidden gnus-cite-attribution-alist)
- (gnus-add-text-properties
- (point) (progn (forward-line 1) (point))
- (nconc (list 'article-type 'cite)
- gnus-hidden-properties))))))))))
+ (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-add-wash-type 'cite)
+ (setq atts gnus-cite-attribution-alist)
+ (while atts
+ (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
+ atts (cdr atts))
+ (while total
+ (setq hidden (car total)
+ total (cdr total))
+ (goto-char (point-min))
+ (forward-line (1- hidden))
+ (unless (assq hidden gnus-cite-attribution-alist)
+ (gnus-add-text-properties
+ (point) (progn (forward-line 1) (point))
+ (nconc (list 'article-type 'cite)
+ gnus-hidden-properties)))))))))
+ (gnus-set-mode-line 'article)))
(defun gnus-article-hide-citation-in-followups ()
"Hide cited text in non-root articles."
;; Each line.
(setq begin (point)
guess-limit (progn (skip-chars-forward "^> \t\r\n") (point))
- end (gnus-point-at-bol 2)
+ end (point-at-bol 2)
start end)
(goto-char begin)
;; Ignore standard Supercite attribution prefix.
;; Ignore very long prefixes.
(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
(setcdr entry (cons line (cdr entry)))
(let ((al (buffer-substring (save-excursion (beginning-of-line 0)
(1+ (point)))
end)))
- (if (not (assoc al al-alist))
- (progn
- (push (list wrote in prefix tag)
- gnus-cite-loose-attribution-alist)
- (push (cons al t) al-alist))))))))
+ (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
(when (< from to)
(push (setq overlay (gnus-make-overlay from to))
gnus-cite-overlay-list)
+ (gnus-overlay-put overlay 'evaporate t)
(gnus-overlay-put overlay 'face face))))))
(defun gnus-cite-toggle (prefix)
(setq found t)))
found)))
+
+;; Highlighting of different citation levels in message-mode.
+;;
+;; Known bugs:
+;;
+;; - XEmacs compatibility: `font-lock-add-keywords' is missing in XEmacs.
+;;
+;; - message-cite-prefix should not be fontified.
+
+(defconst gnus-message-max-citation-depth
+ (length gnus-cite-face-list)
+ "Maximum supported level of citation.")
+
+(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 (eval-when-compile
+ (concat "^\\(?:"
+ message-cite-prefix-regexp
+ "\\)"))
+ limit t)
+ (let ((cdepth
+ (length (apply 'concat
+ (split-string
+ (match-string-no-properties 0)
+ "[ \t [:alnum:]]+"))))
+ (mlist (make-list (* (1+ gnus-message-max-citation-depth)
+ 2)
+ 0)))
+ (setcar (nthcdr (* cdepth 2) mlist)
+ (line-beginning-position))
+ (setcar (nthcdr (1+ (* cdepth 2)) mlist)
+ (line-end-position))
+ (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) list)
+ (setq count (1+ count)))))) ;;
+ "Keywords for highlighting different levels of message citations.")
+
+(defun gnus-message-add-citation-keywords ()
+ "Add font-lock for nested citations to current buffer."
+ (if (fboundp 'font-lock-add-keywords)
+ (font-lock-add-keywords nil gnus-message-citation-keywords)
+ (gnus-message 1 "`font-lock-add-keywords' not supported.")))
+
+(defun gnus-message-remove-citation-keywords ()
+ "Remove font-lock for nested citations from current buffer."
+ (if (fboundp 'font-lock-remove-keywords)
+ (font-lock-remove-keywords nil gnus-message-citation-keywords)
+ (gnus-message 1 "`font-lock-remove-keywords' not supported.")))
+
+(define-minor-mode gnus-message-citation-mode
+ "Toggle `gnus-message-citation-mode' in current buffer.
+This buffer local minor mode provides additional font-lock support for
+nested citations.
+With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG is
+positive."
+ nil ;; init-value
+ "" ;; lighter
+ nil ;; keymap
+ (if gnus-message-citation-mode
+ (gnus-message-add-citation-keywords)
+ (gnus-message-remove-citation-keywords))
+ (font-lock-fontify-buffer))
+
+(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)
;; coding: iso-8859-1
;; End:
+;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
;;; gnus-cite.el ends here
projects / gnus / blobdiff