X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-cite.el;h=7419cedac5f1f05955a67144b8e21f5c57af077e;hb=4c94d8ab77dea518e07526bd19eb7c1c9245adc9;hp=8bb687cc94ca57a0b03cc422f866bc617f4d5f54;hpb=280b9a2b7758886e08334dfdb4b0399676c167c1;p=gnus

diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el
index 8bb687cc9..7419cedac 100644
--- a/lisp/gnus-cite.el
+++ b/lisp/gnus-cite.el
@@ -1,16 +1,16 @@
 ;;; 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
@@ -18,9 +18,7 @@
 ;; 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:
 
@@ -144,6 +142,7 @@ the envelope From line."
   :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.
@@ -164,6 +163,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -177,6 +177,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -190,6 +191,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -203,6 +205,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -216,6 +219,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -229,6 +233,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -242,6 +247,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -255,6 +261,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -268,10 +275,11 @@ It is merged with the face for the cited text belonging to the attribution."
   :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"))
@@ -281,6 +289,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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))
@@ -294,6 +303,7 @@ It is merged with the face for the cited text belonging to the attribution."
   :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
@@ -397,9 +407,7 @@ 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
-    (unless same-buffer
-      (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)
@@ -452,8 +460,7 @@ 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)
+  (with-current-buffer gnus-article-buffer
     (gnus-cite-parse-maybe nil t)
     (let ((alist gnus-cite-prefix-alist)
 	  prefix numbers number marks m)
@@ -513,8 +520,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps
   "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)
+  (with-current-buffer gnus-article-buffer
     (let ((buffer-read-only nil)
 	  (inhibit-point-motion-hooks t)
 	  (marks (gnus-dissect-cited-text))
@@ -542,6 +548,24 @@ If WIDTH (the numerical prefix), use that text width when filling."
 	      gnus-cite-loose-attribution-alist nil
 	      gnus-cite-article nil)))))
 
+(defun gnus-article-natural-long-line-p ()
+  "Return true if the current line is long, and it's natural text."
+  (save-excursion
+    (beginning-of-line)
+    (and
+     ;; The line is long.
+     (> (- (line-end-position) (line-beginning-position))
+	(frame-width))
+     ;; It doesn't start with spaces.
+     (not (looking-at "    "))
+     ;; Not cited text.
+     (let ((line-number (1+ (count-lines (point-min) (point))))
+	   citep)
+       (dolist (elem gnus-cite-prefix-alist)
+	 (when (member line-number (cdr elem))
+	   (setq citep t)))
+       (not citep)))))
+
 (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'.
@@ -550,67 +574,66 @@ always hide."
   (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)
@@ -618,8 +641,8 @@ always hide."
 		`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.
@@ -722,11 +745,9 @@ See also the documentation for `gnus-article-highlight-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)))))
 
@@ -821,13 +842,24 @@ See also the documentation for `gnus-article-highlight-citation'."
       (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
@@ -1058,8 +1090,7 @@ See also the documentation for `gnus-article-highlight-citation'."
 	  (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)))
@@ -1139,8 +1170,8 @@ Returns nil if there is no such line before LIMIT, t otherwise."
 				       "[ \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)
@@ -1159,83 +1190,58 @@ Returns nil if there is no such line before LIMIT, t otherwise."
 	   (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'."
@@ -1252,5 +1258,4 @@ positive."
 ;; coding: iso-8859-1
 ;; End:
 
-;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a
 ;;; gnus-cite.el ends here