xemacs-beta: lisp/gnus/gnus-cite.el comparison

comparison lisp/gnus/gnus-cite.el @ 30:ec9a17fef872 r19-15b98

Import from CVS: tag r19-15b98

author	cvs
date	Mon, 13 Aug 2007 08:52:29 +0200
parents	1917ad0d78d7
children	131b0175ea99

comparison

equal deleted inserted replaced

-:7976500f47f9
+:ec9a17fef872
 Set it to nil to parse all articles."
 :group 'gnus-cite
 :type '(choice (const :tag "all" nil)
 		 integer))
 (defcustom gnus-cite-prefix-regexp
 "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
 "Regexp matching the longest possible citation prefix on a line."
 :group 'gnus-cite
 :type 'regexp)
 (defcustom gnus-cite-max-prefix 20
 "Maximum possible length for a citation prefix."
 :group 'gnus-cite
 :type 'integer)
 (defcustom gnus-supercite-regexp
 (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
 	  ">>>>> +\"\\([^\"\n]+\\)\" +==")
 "Regexp matching normal Supercite attribution lines.
 The first grouping must match prefixes added by other packages."
 :group 'gnus-cite
 "Regexp matching the end of an attribution line.
 The text matching the first grouping will be used as a button."
 :group 'gnus-cite
 :type 'regexp)
 (defface gnus-cite-attribution-face '((t
 				       (:underline t)))
 "Face used for attribution lines.")
 (defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
 "Face used for attribution lines.
 			      (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.")
 (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)
 "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
 ;;; Internal Variables:
 (defvar gnus-cite-article nil)
 (defvar gnus-cite-prefix-alist nil)
 ;; Alist of citation prefixes.
 ;; The cdr is a list of lines with that prefix.
 (defvar gnus-cite-attribution-alist nil)
 ;; Alist of attribution lines.
 ;; The car is a line number.
 ;; 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.
 (defvar gnus-cited-text-button-line-format-alist
 `((?b (marker-position beg) ?d)
 (?e (marker-position end) ?d)
 (?l (- end beg) ?d)))
 (defvar gnus-cited-text-button-line-format-spec nil)
 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'.
 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-suffix' and perhaps
 `gnus-cite-attribution-prefix' are considered attribution lines."
 (interactive (list 'force))
 (save-excursion
 	      prefix (cdr entry)
 	      skip (gnus-cite-find-prefix number)
 	      face (cdr (assoc prefix face-alist)))
 	;; Add attribution button.
 	(goto-line number)
 	(when (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)
 				   'gnus-cite-toggle prefix))
 	;; Highlight attribution line.
 "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-article-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))
 (save-excursion
 (set-buffer gnus-article-buffer)
 (cond
 ((gnus-article-check-hidden-text 'cite arg)
 	(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)))
 	    (while total
 	      (setq hiden (car total)
 		    total (cdr total))
 	      (goto-line hiden)
 	      (unless (assq hiden gnus-cite-attribution-alist)
 		(gnus-add-text-properties
 		 (point) (progn (forward-line 1) (point))
 		 (nconc (list 'article-type 'cite)
 			gnus-hidden-properties))))))))))
 (defun gnus-article-hide-citation-in-followups ()
 (defun gnus-cite-parse-wrapper ()
 ;; Wrap chopped gnus-cite-parse
 (goto-char (point-min))
 (unless (search-forward "\n\n" nil t)
 (goto-char (point-max)))
 (save-excursion
 (gnus-cite-parse-attributions))
 ;; Try to avoid check citation if there is no reason to believe
 ;; that article has citations
 (if (or gnus-cite-always-check
 	  (save-excursion
 	     (save-excursion
 	       (gnus-cite-connect-attributions)))))
 (defun gnus-cite-parse ()
 ;; Parse and connect citation prefixes and attribution lines.
 ;; Parse current buffer searching for citation prefixes.
 (let ((line (1+ (count-lines (point-min) (point))))
 	(case-fold-search t)
 	(max (save-excursion
 	       (goto-char (point-max))
 	;; Each prefix.
 	(setq end (match-end 0)
 	      prefix (buffer-substring begin end))
 	(gnus-set-text-properties 0 (length prefix) nil prefix)
 	(setq entry (assoc prefix alist))
 	(if entry
 	    (setcdr entry (cons line (cdr entry)))
 	  (push (list prefix line) alist))
 	(goto-char begin))
 (goto-char start)
 (setq line (1+ line)))
 	     )
 	    ((< (length numbers) gnus-cite-minimum-match-count)
 	     ;; Too few lines with this prefix.  We keep it a bit
 	     ;; longer in case it is an exact match for an attribution
 	     ;; line, but we don't remove the line from other
 	     ;; prefixes.
 	     (push entry gnus-cite-prefix-alist))
 	    (t
 	     (push entry
 		   gnus-cite-prefix-alist)
 	     ;; Remove articles from other prefixes.
 	     (let ((loop alist)
 		   current)
 	       (while loop
 		 (setq current (car loop)
 		       loop (cdr loop))
 		 (setcdr current
 			 (gnus-set-difference (cdr current) numbers)))))))))
 (defun gnus-cite-parse-attributions ()
 (let (al-alist)
 ;; Parse attributions
 	(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))))))))
 (defun gnus-cite-connect-attributions ()
 ;; Connect attributions to citations
 ;; Parse current buffer searching for attribution lines.
 ;; Find exact supercite citations.
 (gnus-cite-match-attributions 'small nil
 				(lambda (prefix tag)
 				  (when tag
 				    (concat "\\`"
 					    (regexp-quote prefix) "[ \t]*"
 					    (regexp-quote tag) ">"))))
 ;; Find loose supercite citations after attributions.
 (gnus-cite-match-attributions 'small t
 				(lambda (prefix tag)
 				  (when tag
 ;; will be considered.
 ;;
 ;; If FUN is non-nil, it will be called with the arguments (WROTE
 ;; PREFIX TAG) and expected to return a regular expression.  Only
 ;; citations whose prefix matches the regular expression will be
 ;; considered.
 ;;
 ;; WROTE is the attribution line number.
 ;; PREFIX is the attribution line prefix.
 ;; TAG is the Supercite tag on the attribution line.
 (let ((atts gnus-cite-loose-attribution-alist)
 	(case-fold-search t)
 	    regexp (if fun (funcall fun prefix tag) "")
 	    size (cond ((eq sort 'small) t)
 		       ((eq sort 'first) nil)
 		       (t (< (length (gnus-cite-find-loose prefix)) 2)))
 	    limit (if after wrote -1)
 	    smallest 1000000
 	    best nil)
 (let ((cites gnus-cite-loose-prefix-alist)
 	    cite candidate numbers first compare)
 	(while cites
 	  (setq cite (car cites)
 	(cond ((get-text-property (point) 'invisible)
 	       (remove-text-properties (point) (progn (forward-line 1) (point))
 				       gnus-hidden-properties))
 	      ((assq number gnus-cite-attribution-alist))
 	      (t
 	       (gnus-add-text-properties
 		(point) (progn (forward-line 1) (point))
 		(nconc (list 'article-type 'cite)
 		       gnus-hidden-properties))))))))
 (defun gnus-cite-find-prefix (line)

Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-cite.el @ 30:ec9a17fef872 r19-15b98