;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
: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.
: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))
: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))
: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))
: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))
: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))
: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))
: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))
: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))
: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 "medium purple"))
+ (:foreground "plum1"))
(((class color)
(background light))
(:foreground "medium purple"))
: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))
: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
(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
"[ \t [:alnum:]]+")))
gnus-message-max-citation-depth))
(mlist (make-list (* (1+ gnus-message-max-citation-depth) 2) nil))
- (start (line-beginning-position))
- (end (line-end-position)))
+ (start (point-at-bol))
+ (end (point-at-eol)))
(setcar mlist start)
(setcar (cdr mlist) end)
(setcar (nthcdr (* cdepth 2) mlist) start)
(setq count (1+ count)))))) ;;
"Keywords for highlighting different levels of message citations.")
-(eval-when-compile
- (autoload 'font-lock-add-keywords "font-lock")
- (autoload 'font-lock-compile-keyword "font-lock")
- (autoload 'font-lock-compile-keywords "font-lock")
- (autoload 'font-lock-remove-keywords "font-lock")
- (defvar font-lock-keywords))
-
-(defun gnus-test-font-lock-add-keywords ()
- "Return non-nil if `font-lock-add-keywords' seems to work.
-Emacs uses the `(t KEYWORDS COMPILED...)' form for compiled keywords
-while Emacs uses the `(t COMPILED...)' form. In some version(s) of
-XEmacs, `font-lock-add-keywords' and `font-lock-remove-keywords' assume
-the form of the Emacs style for compiled keywords mistakenly."
- (if (featurep 'xemacs)
- (progn
- (require 'font-lock)
- (if (fboundp 'font-lock-add-keywords)
- (let ((default-major-mode 'fundamental-mode))
- (with-temp-buffer
- (let ((font-lock-keywords '(t (x) (y)))
- font-lock-auto-fontify font-lock-mode-enable-list)
- (ignore-errors
- (font-lock-add-keywords nil '((z)))
- (assq 'y (cdr-safe font-lock-keywords))))))))
- t))
+(defvar font-lock-defaults-computed)
+(defvar font-lock-keywords)
+(defvar font-lock-set-defaults)
-(defun gnus-message-add-citation-keywords ()
- "Add font-lock for nested citations to current buffer."
- (if (gnus-test-font-lock-add-keywords)
- (font-lock-add-keywords nil gnus-message-citation-keywords 'append)
- (font-lock-set-defaults)
- (let ((was-compiled (eq (car font-lock-keywords) t)))
- (setq font-lock-keywords (copy-sequence (if was-compiled
- (cdr font-lock-keywords)
- font-lock-keywords)))
- (dolist (keyword gnus-message-citation-keywords)
- (setq font-lock-keywords
- (delete (font-lock-compile-keyword keyword)
- (delete keyword font-lock-keywords))))
- (let ((old (if (eq (car-safe font-lock-keywords) t)
- (cdr font-lock-keywords)
- font-lock-keywords)))
- (setq font-lock-keywords (append old gnus-message-citation-keywords)))
- (if was-compiled
- (setq font-lock-keywords
- (font-lock-compile-keywords font-lock-keywords))))))
-
-(defun gnus-message-remove-citation-keywords ()
- "Remove font-lock for nested citations from current buffer."
- (if (gnus-test-font-lock-add-keywords)
- (font-lock-remove-keywords nil gnus-message-citation-keywords)
- (font-lock-set-defaults)
- (let ((was-compiled (eq (car font-lock-keywords) t)))
- (if was-compiled
- (setq font-lock-keywords (cdr font-lock-keywords)))
- (setq font-lock-keywords (copy-sequence font-lock-keywords))
- (dolist (keyword gnus-message-citation-keywords)
- (setq font-lock-keywords
- (delete (font-lock-compile-keyword keyword)
- (delete keyword font-lock-keywords))))
- (if was-compiled
- (setq font-lock-keywords
- (font-lock-compile-keywords font-lock-keywords))))))
+(eval-and-compile
+ (unless (featurep 'xemacs)
+ (autoload 'font-lock-set-defaults "font-lock")))
(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."
+With prefix ARG, turn `gnus-message-citation-mode' on if and only if ARG
+is positive.
+Automatically turn `font-lock-mode' on when `gnus-message-citation-mode'
+is turned on."
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))
+ (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'."
;; coding: iso-8859-1
;; End:
-;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
+;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
;;; gnus-cite.el ends here
projects / gnus / blobdiff