* mml2015.el (mml2015-epg-sign): Ask user whether to skip or abort if

[gnus] / lisp / gnus-cite.el

diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el
index f25d816..d1f4b3c 100644 (file)
--- a/lisp/gnus-cite.el
+++ b/lisp/gnus-cite.el
@@ -1,7 +1,7 @@
 ;;; gnus-cite.el --- parse citations in articles for Gnus
 
 ;;; gnus-cite.el --- parse citations in articles for Gnus
 

-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
-;;        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
 
 
 ;; Author: Per Abhiddenware
 


@@ -19,14 +19,17 @@
 
 ;; 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
 
 ;; 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))
 
 ;;; 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)
 
 (require 'gnus)
 (require 'gnus-range)


@@ -136,131 +139,165 @@ the envelope From line."
   :group 'gnus-cite
   :type 'boolean)
 
   :group 'gnus-cite
   :type 'boolean)
 

-(defface gnus-cite-attribution-face '((t
-                                      (:italic t)))
-  "Face used for attribution lines.")
+(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
+(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)
 
   "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
 
 (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,
   "*List of faces used for highlighting citations.
 
 When there are citations from multiple articles in the same message,


@@ -286,8 +323,7 @@ This should make it easier to see who wrote what."
 
 ;; This has to go here because its default value depends on
 ;; gnus-cite-face-list.
 
 ;; 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
   "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


@@ -339,7 +375,7 @@ in a boring face, then the pages will be skipped."
 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
 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.
 
 Text is considered cited if at least `gnus-cite-minimum-match-count'
 lines matches `message-cite-prefix-regexp' with the same prefix.


@@ -1003,6 +1039,7 @@ See also the documentation for `gnus-article-highlight-citation'."
        (when (< from to)
          (push (setq overlay (gnus-make-overlay from to))
                gnus-cite-overlay-list)
        (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)
          (gnus-overlay-put overlay 'face face))))))
 
 (defun gnus-cite-toggle (prefix)


@@ -1066,6 +1103,86 @@ See also the documentation for `gnus-article-highlight-citation'."
          (setq found t)))
       found)))
 
          (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)
 (gnus-ems-redefine)
 
 (provide 'gnus-cite)