;;; 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-2012 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
;; 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 <http://www.gnu.org/licenses/>.
;;; 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)
+(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-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)
+(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-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,
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))
+ :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."
;; 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 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 `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))
- (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)
(defun gnus-dissect-cited-text ()
"Dissect the article buffer looking for cited text."
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(gnus-cite-parse-maybe nil t)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
(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 width)
+(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."
- (interactive (list t current-prefix-arg))
- (save-excursion
- (set-buffer gnus-article-buffer)
+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))
(fill-prefix
(if (string= (cdar marks) "") ""
(concat (cdar marks) " ")))
+ (do-fill (not long-lines))
use-hard-newlines)
- (fill-region (point-min) (point-max)))
+ (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
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'.
(interactive (append (gnus-article-hidden-arg) (list 'force)))
(gnus-set-format 'cited-opened-text-button t)
(gnus-set-format 'cited-closed-text-button t)
- (save-excursion
- (set-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
+ (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 (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)
+ ;; 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
+ (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)
`gnus-article-toggle-cited-text
(list (cons beg end) start))
(point))
- 'article-type 'annotation)
- (set-marker beg (point))))))))
+ 'article-type 'annotation)
+ (set-marker beg (point))))))))
(defun gnus-article-toggle-cited-text (args &optional arg)
"Toggle hiding the text in REGION.
(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)))))
;; 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)))
(setq line (1+ line)))
;; Horrible special case for some Microsoft mailers.
(goto-char (point-min))
- (when (re-search-forward gnus-cite-unsightly-citation-regexp max t)
- (setq begin (count-lines (point-min) (point)))
- (setq end (count-lines (point-min) max))
- (setq entry nil)
- (while (< begin end)
- (push begin entry)
- (setq begin (1+ begin)))
+ (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
(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)
- (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)))
(while vars
(make-local-variable (pop vars)))))
-(defun gnus-cited-line-p ()
- "Say whether the current line is a cited line."
- (save-excursion
- (beginning-of-line)
- (let ((found nil))
- (dolist (prefix (mapcar 'car gnus-cite-prefix-alist))
- (when (string= (buffer-substring (point) (+ (length prefix) (point)))
- prefix)
- (setq found t)))
- found)))
+;; 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.")
+
+(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)
+ (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 ((symbol-value 'font-lock-mode)
+ (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)
projects / gnus / blobdiff