New version.

1 files changed, 230 insertions, 85 deletions

diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el
index 5a5a247fc24..bc85ea42be0 100644
--- a/lisp/gnus-cite.el
+++ b/lisp/gnus-cite.el
@@ -1,6 +1,5 @@
 ;;; gnus-cite.el --- parse citations in articles for Gnus
-
-;; Copyright (C) 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1995,96 Free Software Foundation, Inc.
 
 ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
 ;; Keywords: news, mail
@@ -29,13 +28,19 @@
 (require 'gnus)
 (require 'gnus-msg)
 (require 'gnus-ems)
+(eval-when-compile (require 'cl))
 
 (eval-and-compile
-  (autoload 'gnus-article-add-button "gnus-vis")
-  )
+  (autoload 'gnus-article-add-button "gnus-vis"))
 
 ;;; Customization:
 
+(defvar gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
+  "Format of cited text buttons.")
+
+(defvar gnus-cited-lines-visible nil
+  "The number of lines of hidden cited text to remain visible.")
+
 (defvar gnus-cite-parse-max-size 25000
   "Maximum article size (in bytes) where parsing citations is allowed.
 Set it to nil to parse all articles.")
@@ -45,20 +50,20 @@ Set it to nil to parse all articles.")
   "Regexp matching the longest possible citation prefix on a line.")
 
 (defvar gnus-cite-max-prefix 20
-  "Maximal possible length for a citation prefix.")
+  "Maximum possible length for a citation prefix.")
 
 (defvar gnus-supercite-regexp 
   (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
 	  ">>>>> +\"\\([^\"\n]+\\)\" +==")
-  "Regexp matching normal SuperCite attribution lines.
-The first regexp group should match a prefix added by another package.")
+  "Regexp matching normal Supercite attribution lines.
+The first grouping must match prefixes added by other packages.")
 
 (defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
-  "Regexp matching mangled SuperCite attribution lines.
-The first regexp group should match the SuperCite attribution.")
+  "Regexp matching mangled Supercite attribution lines.
+The first regexp group should match the Supercite attribution.")
 
 (defvar gnus-cite-minimum-match-count 2
-  "Minimal number of identical prefix'es before we believe it is a citation.")
+  "Minimum number of identical prefixes before we believe it's a citation.")
 
 ;see gnus-cus.el
 ;(defvar gnus-cite-face-list 
@@ -78,7 +83,7 @@ The first regexp group should match the SuperCite attribution.")
 (defvar gnus-cite-attribution-prefix "in article\\|in <"
   "Regexp matching the beginning of an attribution line.")
 
-(defvar gnus-cite-attribution-postfix
+(defvar gnus-cite-attribution-suffix
   "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
   "Regexp matching the end of an attribution line.
 The text matching the first grouping will be used as a button.")
@@ -112,9 +117,7 @@ The text matching the first grouping will be used as a button.")
 
 ;;; Internal Variables:
 
-(defvar gnus-article-length nil)
-;; Length of article last time we parsed it.
-;; BUG! KLUDGE! UGLY! FIX ME!
+(defvar gnus-cite-article nil)
 
 (defvar gnus-cite-prefix-alist nil)
 ;; Alist of citation prefixes.  
@@ -135,7 +138,13 @@ The text matching the first grouping will be used as a button.")
 ;; WROTE: is the attribution line number
 ;; IN: is the line number of the previous line if part of the same attribution,
 ;; PREFIX: Is the citation prefix of the attribution line(s), and
-;; TAG: Is a SuperCite tag, if any.
+;; TAG: Is a Supercite tag, if any.
+
+(defvar gnus-cited-text-button-line-format-alist 
+  `((?b beg ?d)
+    (?e end ?d)
+    (?l (- end beg) ?d)))
+(defvar gnus-cited-text-button-line-format-spec nil)
 
 ;;; Commands:
 
@@ -149,7 +158,7 @@ corresponding citation merged with `gnus-cite-attribution-face'.
 Text is considered cited if at least `gnus-cite-minimum-match-count'
 lines matches `gnus-cite-prefix-regexp' with the same prefix.  
 
-Lines matching `gnus-cite-attribution-postfix' and perhaps
+Lines matching `gnus-cite-attribution-suffix' and perhaps
 `gnus-cite-attribution-prefix' are considered attribution lines."
   (interactive (list 'force))
   ;; Create dark or light faces if necessary.
@@ -193,7 +202,7 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
 	      face (cdr (assoc prefix face-alist)))
 	;; Add attribution button.
 	(goto-line number)
-	(if (re-search-forward gnus-cite-attribution-postfix 
+	(if (re-search-forward gnus-cite-attribution-suffix 
 			       (save-excursion (end-of-line 1) (point))
 			       t)
 	    (gnus-article-add-button (match-beginning 1) (match-end 1)
@@ -210,76 +219,203 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
 	      skip (gnus-cite-find-prefix number))
 	(gnus-cite-add-face number skip gnus-cite-attribution-face)))))
 
-(defun gnus-article-hide-citation (&optional force)
-  "Hide all cited text except attribution lines.
-See the documentation for `gnus-article-highlight-citation'."
-  (interactive (list 'force))
+(defun gnus-dissect-cited-text ()
+  "Dissect the article buffer looking for cited text."
   (save-excursion
     (set-buffer gnus-article-buffer)
-    (gnus-cite-parse-maybe force)
-    (let ((buffer-read-only nil)
-	  (alist gnus-cite-prefix-alist)
-	  (inhibit-point-motion-hooks t)
-	  numbers number)
+    (gnus-cite-parse-maybe)
+    (let ((alist gnus-cite-prefix-alist)
+	  prefix numbers number marks m)
+      ;; Loop through citation prefixes.
       (while alist
-	(setq numbers (cdr (car alist))
-	      alist (cdr alist))
+	(setq numbers (pop alist)
+	      prefix (pop numbers))
 	(while numbers
-	  (setq number (car numbers)
-		numbers (cdr numbers))
-	  (goto-line number)
-	  (or (assq number gnus-cite-attribution-alist)
-	      (add-text-properties (point) (progn (forward-line 1) (point))
-				   gnus-hidden-properties)))))))
-
-(defun gnus-article-hide-citation-maybe (&optional force)
-  "Hide cited text that has an attribution line.
+	  (setq number (pop numbers))
+	  (goto-char (point-min))
+	  (forward-line number)
+	  (push (cons (point-marker) "") marks)
+	  (while (and numbers
+		      (= (1- number) (car numbers)))
+	    (setq number (pop numbers)))
+	  (goto-char (point-min))
+	  (forward-line (1- number))
+	  (push (cons (point-marker) prefix) marks)))
+      (goto-char (point-min))
+      (search-forward "\n\n" nil t)
+      (push (cons (point-marker) "") marks)
+      (goto-char (point-max))
+      (re-search-backward gnus-signature-separator nil t)
+      (push (cons (point-marker) "") marks)
+      (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
+      (let* ((omarks marks))
+	(setq marks nil)
+	(while (cdr omarks)
+	  (if (= (caar omarks) (caadr omarks))
+	      (progn
+		(unless (equal (cdar omarks) "")
+		  (push (car omarks) marks))
+		(unless (equal (cdadr omarks) "")
+		  (push (cadr omarks) marks))
+		(setq omarks (cdr omarks)))
+	    (push (car omarks) marks))
+	  (setq omarks (cdr omarks)))
+	(when (car omarks)
+	  (push (car omarks) marks))
+	(setq marks (setq m (nreverse marks)))
+	(while (cddr m)
+	  (if (and (equal (cdadr m) "")
+		   (equal (cdar m) (cdaddr m))
+		   (goto-char (caadr m))
+		   (forward-line 1)
+		   (= (point) (caaddr m)))
+	      (setcdr m (cdddr m))
+	    (setq m (cdr m))))
+	marks))))
+	    
+
+(defun gnus-article-fill-cited-article (&optional force)
+  "Do word wrapping in the current article."
+  (interactive (list t))
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (let ((buffer-read-only nil)
+	  (inhibit-point-motion-hooks t)
+	  (marks (gnus-dissect-cited-text))
+	  (adaptive-fill-mode nil))
+      (save-restriction
+	(while (cdr marks)
+	  (widen)
+	  (narrow-to-region (caar marks) (caadr marks))
+	  (let ((adaptive-fill-regexp
+		 (concat "^" (regexp-quote (cdar marks)) " *"))
+		(fill-prefix (cdar marks)))
+	    (fill-region (point-min) (point-max)))
+	  (set-marker (caar marks) nil)
+	  (setq marks (cdr marks)))
+	(when marks
+	  (set-marker (caar marks) nil))))))
+
+(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'.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+  (interactive (append (gnus-hidden-arg) (list 'force)))
+  (setq gnus-cited-text-button-line-format-spec 
+	(gnus-parse-format gnus-cited-text-button-line-format 
+			   gnus-cited-text-button-line-format-alist t))
+  (unless (gnus-article-check-hidden-text 'cite arg)
+    (save-excursion
+      (set-buffer gnus-article-buffer)
+      (let ((buffer-read-only nil)
+	    (marks (gnus-dissect-cited-text))
+	    (inhibit-point-motion-hooks t)
+	    (props (nconc (list 'gnus-type 'cite)
+			  gnus-hidden-properties))
+	    beg end)
+	(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 gnus-cited-lines-visible)
+	    (if (>= (point) end)
+		(setq beg nil)
+	      (setq beg (point-marker))))
+	  (when (and beg end)
+	    (gnus-add-text-properties beg end props)
+	    (goto-char beg)
+	    (unless (save-excursion (search-backward "\n\n" nil t))
+	      (insert "\n"))
+	    (gnus-article-add-button
+	     (point)
+	     (progn (eval gnus-cited-text-button-line-format-spec) (point))
+	     `gnus-article-toggle-cited-text (cons beg end))
+	    (set-marker beg (point))))))))
+
+(defun gnus-article-toggle-cited-text (region)
+  "Toggle hiding the text in REGION."
+  (let (buffer-read-only)
+    (funcall
+     (if (text-property-any
+	  (car region) (1- (cdr region))
+	  (car gnus-hidden-properties) (cadr gnus-hidden-properties))
+	 'remove-text-properties 'gnus-add-text-properties)
+     (car region) (cdr region) gnus-hidden-properties)))
+
+(defun gnus-article-hide-citation-maybe (&optional arg force)
+  "Toggle hiding of cited text that has an attribution line.
+If given a negative prefix, always show; if given a positive prefix,
+always hide.
 This will do nothing unless at least `gnus-cite-hide-percentage'
 percent and at least `gnus-cite-hide-absolute' lines of the body is
 cited text with attributions.  When called interactively, these two
 variables are ignored.
 See also the documentation for `gnus-article-highlight-citation'."
-  (interactive (list 'force))
+  (interactive (append (gnus-hidden-arg) (list 'force)))
+  (unless (gnus-article-check-hidden-text 'cite arg)
+    (save-excursion
+      (set-buffer gnus-article-buffer)
+      (gnus-cite-parse-maybe force)
+      (goto-char (point-min))
+      (search-forward "\n\n" nil t)
+      (let ((start (point))
+	    (atts gnus-cite-attribution-alist)
+	    (buffer-read-only nil)
+	    (inhibit-point-motion-hooks t)
+	    (hiden 0)
+	    total)
+	(goto-char (point-max))
+	(re-search-backward gnus-signature-separator nil t)
+	(setq total (count-lines start (point)))
+	(while atts
+	  (setq hiden (+ hiden (length (cdr (assoc (cdar atts)
+						   gnus-cite-prefix-alist))))
+		atts (cdr atts)))
+	(if (or force
+		(and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
+		     (> hiden gnus-cite-hide-absolute)))
+	    (progn
+	      (setq atts gnus-cite-attribution-alist)
+	      (while atts
+		(setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
+		      atts (cdr atts))
+		(while total
+		  (setq hiden (car total)
+			total (cdr total))
+		  (goto-line hiden)
+		  (or (assq hiden gnus-cite-attribution-alist)
+		      (gnus-add-text-properties 
+		       (point) (progn (forward-line 1) (point))
+		       (nconc (list 'gnus-type 'cite)
+			      gnus-hidden-properties)))))))))))
+
+(defun gnus-article-hide-citation-in-followups ()
+  "Hide cited text in non-root articles."
+  (interactive)
   (save-excursion
     (set-buffer gnus-article-buffer)
-    (gnus-cite-parse-maybe force)
-    (goto-char (point-min))
-    (search-forward "\n\n" nil t)
-    (let ((start (point))
-	  (atts gnus-cite-attribution-alist)
-	  (buffer-read-only nil)
-	  (inhibit-point-motion-hooks t)
-	  (hiden 0)
-	  total)
-      (goto-char (point-max))
-      (re-search-backward gnus-signature-separator nil t)
-      (setq total (count-lines start (point)))
-      (while atts
-	(setq hiden (+ hiden (length (cdr (assoc (cdr (car atts))
-						 gnus-cite-prefix-alist))))
-	      atts (cdr atts)))
-      (if (or force
-	      (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
-		   (> hiden gnus-cite-hide-absolute)))
-	  (progn
-	    (setq atts gnus-cite-attribution-alist)
-	    (while atts
-	      (setq total (cdr (assoc (cdr (car atts)) gnus-cite-prefix-alist))
-		    atts (cdr atts))
-	      (while total
-		(setq hiden (car total)
-		      total (cdr total))
-		(goto-line hiden)
-		(or (assq hiden gnus-cite-attribution-alist)
-		    (add-text-properties (point) 
-					 (progn (forward-line 1) (point))
-					 gnus-hidden-properties)))))))))
+    (let ((article (cdr gnus-article-current)))
+      (unless (save-excursion
+		(set-buffer gnus-summary-buffer)
+		(gnus-article-displayed-root-p article))
+	(gnus-article-hide-citation)))))
 
 ;;; Internal functions:
 
 (defun gnus-cite-parse-maybe (&optional force)
   ;; Parse if the buffer has changes since last time.
-  (if (eq gnus-article-length (- (point-max) (point-min)))
+  (if (equal gnus-cite-article gnus-article-current)
       ()
     ;;Reset parser information.
     (setq gnus-cite-prefix-alist nil
@@ -291,7 +427,8 @@ See also the documentation for `gnus-article-highlight-citation'."
 	     gnus-cite-parse-max-size
 	     (> (buffer-size) gnus-cite-parse-max-size))
 	()
-      (setq gnus-article-length (- (point-max) (point-min)))
+      (setq gnus-cite-article (cons (car gnus-article-current)
+				    (cdr gnus-article-current)))
       (gnus-cite-parse))))
 
 (defun gnus-cite-parse ()
@@ -315,7 +452,7 @@ See also the documentation for `gnus-article-highlight-citation'."
 	    end (progn (beginning-of-line 2) (point))
 	    start end)
       (goto-char begin)
-      ;; Ignore standard SuperCite attribution prefix.
+      ;; Ignore standard Supercite attribution prefix.
       (if (looking-at gnus-supercite-regexp)
 	  (if (match-end 1)
 	      (setq end (1+ (match-end 1)))
@@ -327,7 +464,7 @@ See also the documentation for `gnus-article-highlight-citation'."
 	;; Each prefix.
 	(setq end (match-end 0)
 	      prefix (buffer-substring begin end))
-	(set-text-properties 0 (length prefix) nil prefix)
+	(gnus-set-text-properties 0 (length prefix) nil prefix)
 	(setq entry (assoc prefix alist))
 	(if entry 
 	    (setcdr entry (cons line (cdr entry)))
@@ -374,7 +511,7 @@ See also the documentation for `gnus-article-highlight-citation'."
   ;; Parse current buffer searching for attribution lines.
   (goto-char (point-min))
   (search-forward "\n\n" nil t)
-  (while (re-search-forward gnus-cite-attribution-postfix (point-max) t)
+  (while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
     (let* ((start (match-beginning 0))
 	   (end (match-end 0))
 	   (wrote (count-lines (point-min) end))
@@ -392,7 +529,7 @@ See also the documentation for `gnus-article-highlight-citation'."
 					    (beginning-of-line 0)
 					    (point))
 					  t)
-		      (not (re-search-forward gnus-cite-attribution-postfix
+		      (not (re-search-forward gnus-cite-attribution-suffix
 					      start t))
 		      (count-lines (point-min) (1+ (point)))))))
       (if (eq wrote in)
@@ -463,7 +600,7 @@ See also the documentation for `gnus-article-highlight-citation'."
   ;; 
   ;; WROTE is the attribution line number.
   ;; PREFIX is the attribution line prefix.
-  ;; TAG is the SuperCite tag on the attribution line.
+  ;; TAG is the Supercite tag on the attribution line.
   (let ((atts gnus-cite-loose-attribution-alist)
 	(case-fold-search t)
 	att wrote in prefix tag regexp limit smallest best size)
@@ -536,18 +673,19 @@ See also the documentation for `gnus-article-highlight-citation'."
 
 (defun gnus-cite-add-face (number prefix face)
   ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
-  (if face
-      (let ((inhibit-point-motion-hooks t)
-	    from to)
-	(goto-line number)
+  (when face
+    (let ((inhibit-point-motion-hooks t)
+	  from to)
+      (goto-line number)
+      (unless (eobp) ;; Sometimes things become confused.
 	(forward-char (length prefix))
 	(skip-chars-forward " \t")
 	(setq from (point))
 	(end-of-line 1)
 	(skip-chars-backward " \t")
 	(setq to (point))
-	(if (< from to)
-	    (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
+	(when (< from to)
+	  (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
 
 (defun gnus-cite-toggle (prefix)
   (save-excursion
@@ -565,8 +703,10 @@ See also the documentation for `gnus-article-highlight-citation'."
 				       gnus-hidden-properties))
 	      ((assq number gnus-cite-attribution-alist))
 	      (t
-	       (add-text-properties (point) (progn (forward-line 1) (point))
-				    gnus-hidden-properties)))))))
+	       (gnus-add-text-properties 
+		(point) (progn (forward-line 1) (point))
+		 (nconc (list 'gnus-type 'cite)
+			gnus-hidden-properties))))))))
 
 (defun gnus-cite-find-prefix (line)
   ;; Return citation prefix for LINE.
@@ -580,6 +720,11 @@ See also the documentation for `gnus-article-highlight-citation'."
 	  (setq prefix (car entry))))
     prefix))
 
+(gnus-add-shutdown 'gnus-cache-close 'gnus)
+
+(defun gnus-cache-close ()
+  (setq gnus-cite-prefix-alist nil))
+
 (gnus-ems-redefine)
 
 (provide 'gnus-cite)