X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-cite.el;h=9c1d57bbd2c973acd85dd0fe5d4048f060c3629d;hp=3f4b7f534c59163d6f3585eaaf19b54c84044858;hb=125d88b46ad2efa065f06d5dac37a245b488985a;hpb=39a5d09a66e4cc8dea3a855887a6441fd0bddcae diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el index 3f4b7f534..9c1d57bbd 100644 --- a/lisp/gnus-cite.el +++ b/lisp/gnus-cite.el @@ -1,6 +1,6 @@ ;;; gnus-cite.el --- parse citations in articles for Gnus -;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 +;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Per Abhiddenware @@ -29,8 +29,8 @@ (eval-when-compile (require 'cl)) (require 'gnus) -(require 'gnus-art) (require 'gnus-range) +(require 'gnus-art) (require 'message) ; for message-cite-prefix-regexp ;;; Customization: @@ -41,19 +41,6 @@ :link '(custom-manual "(gnus)Article Highlighting") :group 'gnus-article) -(defcustom gnus-cite-reply-regexp - "^\\(Subject: Re\\|In-Reply-To\\|References\\):" - "*If headers match this regexp it is reasonable to believe that -article has citations." - :group 'gnus-cite - :type 'string) - -(defcustom gnus-cite-always-check nil - "Check article always for citations. Set it t to check all articles." - :group 'gnus-cite - :type '(choice (const :tag "no" nil) - (const :tag "yes" t))) - (defcustom gnus-cited-opened-text-button-line-format "%(%{[-]%}%)\n" "Format of opened cited text buttons." :group 'gnus-cite @@ -104,19 +91,42 @@ The first regexp group should match the Supercite attribution." :group 'gnus-cite :type 'integer) +;; Some Microsoft products put in a citation that extends to the +;; remainder of the message: +;; +;; -----Original Message----- +;; From: ... +;; To: ... +;; Sent: ... [date, in non-RFC-2822 format] +;; Subject: ... +;; +;; Cited message, with no prefixes +;; +;; The four headers are always the same. But note they are prone to +;; folding without additional indentation. +;; +;; Others use "----- Original Message -----" instead, and properly quote +;; the body using "> ". This style is handled without special cases. + (defcustom gnus-cite-attribution-prefix - "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|-----Original Message-----" + "In article\\|in <\\|On \\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),\\|----- ?Original Message ?-----" "*Regexp matching the beginning of an attribution line." :group 'gnus-cite :type 'regexp) (defcustom gnus-cite-attribution-suffix - "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|-----Original Message-----\\)[ \t]*$" + "\\(\\(wrote\\|writes\\|said\\|says\\|>\\)\\(:\\|\\.\\.\\.\\)\\|----- ?Original Message ?-----\\)[ \t]*$" "*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) +(defcustom gnus-cite-unsightly-citation-regexp + "^-----Original Message-----\nFrom: \\(.+\n\\)+\n" + "Regexp matching Microsoft-type rest-of-message citations." + :group 'gnus-cite + :type 'regexp) + (defface gnus-cite-attribution-face '((t (:italic t))) "Face used for attribution lines.") @@ -259,6 +269,22 @@ This should make it easier to see who wrote what." :group 'gnus-cite :type 'integer) +(defcustom gnus-cite-blank-line-after-header t + "If non-nil, put a blank line between the citation header and the button." + :group 'gnus-cite + :type 'boolean) + +;; 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) + "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 +in a boring face, then the pages will be skipped." + :type '(repeat face) + :group 'gnus-article-hiding) + ;;; Internal Variables: (defvar gnus-cite-article nil) @@ -347,7 +373,7 @@ Lines matching `gnus-cite-attribution-suffix' and perhaps (goto-char (point-min)) (forward-line (1- number)) (when (re-search-forward gnus-cite-attribution-suffix - (save-excursion (end-of-line 1) (point)) + (point-at-eol) t) (gnus-article-add-button (match-beginning 1) (match-end 1) 'gnus-cite-toggle prefix)) @@ -441,7 +467,8 @@ If WIDTH (the numerical prefix), use that text width when filling." (concat "^" (regexp-quote (cdar marks)) " *")) (fill-prefix (if (string= (cdar marks) "") "" - (concat (cdar marks) " ")))) + (concat (cdar marks) " "))) + use-hard-newlines) (fill-region (point-min) (point-max))) (set-marker (caar marks) nil) (setq marks (cdr marks))) @@ -510,15 +537,15 @@ always hide." (setq beg nil) (setq end (point-marker)))))) (when (and beg end) - (or (memq 'cite gnus-article-wash-types) - (push 'cite gnus-article-wash-types)) + (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) - (unless (save-excursion (search-backward "\n\n" nil t)) + (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)) @@ -557,8 +584,7 @@ means show, nil means toggle." 'article-type 'cite beg end (cons 'article-type (cons 'cite gnus-hidden-properties)))) - (or (memq 'cite gnus-article-wash-types) - (push 'cite gnus-article-wash-types)) + (gnus-add-wash-type 'cite) (gnus-add-text-properties-when 'article-type nil beg end (cons 'article-type (cons 'cite @@ -593,41 +619,44 @@ cited text with attributions. When called interactively, these two variables are ignored. See also the documentation for `gnus-article-highlight-citation'." (interactive (append (gnus-article-hidden-arg) '(force))) - (unless (gnus-article-check-hidden-text 'cite arg) - (save-excursion - (set-buffer gnus-article-buffer) - (gnus-cite-parse-maybe force) - (article-goto-body) - (let ((start (point)) - (atts gnus-cite-attribution-alist) - (buffer-read-only nil) - (inhibit-point-motion-hooks t) - (hidden 0) - total) - (goto-char (point-max)) - (gnus-article-search-signature) - (setq total (count-lines start (point))) - (while atts - (setq hidden (+ hidden (length (cdr (assoc (cdar atts) - gnus-cite-prefix-alist)))) - atts (cdr atts))) - (when (or force - (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) - (> hidden gnus-cite-hide-absolute))) - (setq atts gnus-cite-attribution-alist) + (with-current-buffer gnus-article-buffer + (gnus-delete-wash-type 'cite) + (unless (gnus-article-check-hidden-text 'cite arg) + (save-excursion + (gnus-cite-parse-maybe force) + (article-goto-body) + (let ((start (point)) + (atts gnus-cite-attribution-alist) + (buffer-read-only nil) + (inhibit-point-motion-hooks t) + (hidden 0) + total) + (goto-char (point-max)) + (gnus-article-search-signature) + (setq total (count-lines start (point))) (while atts - (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) - atts (cdr atts)) - (while total - (setq hidden (car total) - total (cdr total)) - (goto-char (point-min)) - (forward-line (1- hidden)) - (unless (assq hidden gnus-cite-attribution-alist) - (gnus-add-text-properties - (point) (progn (forward-line 1) (point)) - (nconc (list 'article-type 'cite) - gnus-hidden-properties)))))))))) + (setq hidden (+ hidden (length (cdr (assoc (cdar atts) + gnus-cite-prefix-alist)))) + atts (cdr atts))) + (when (or force + (and (> (* 100 hidden) (* gnus-cite-hide-percentage total)) + (> hidden gnus-cite-hide-absolute))) + (gnus-add-wash-type 'cite) + (setq atts gnus-cite-attribution-alist) + (while atts + (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist)) + atts (cdr atts)) + (while total + (setq hidden (car total) + total (cdr total)) + (goto-char (point-min)) + (forward-line (1- hidden)) + (unless (assq hidden gnus-cite-attribution-alist) + (gnus-add-text-properties + (point) (progn (forward-line 1) (point)) + (nconc (list 'article-type 'cite) + gnus-hidden-properties))))))))) + (gnus-set-mode-line 'article))) (defun gnus-article-hide-citation-in-followups () "Hide cited text in non-root articles." @@ -662,11 +691,13 @@ See also the documentation for `gnus-article-highlight-citation'." (defun gnus-cite-delete-overlays () (dolist (overlay gnus-cite-overlay-list) - (when (or (not (gnus-overlay-end overlay)) - (and (>= (gnus-overlay-end overlay) (point-min)) - (<= (gnus-overlay-end overlay) (point-max)))) - (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) - (gnus-delete-overlay overlay)))) + (ignore-errors + (when (or (not (gnus-overlay-end overlay)) + (and (>= (gnus-overlay-end overlay) (point-min)) + (<= (gnus-overlay-end overlay) (point-max)))) + (setq gnus-cite-overlay-list (delete overlay gnus-cite-overlay-list)) + (ignore-errors + (gnus-delete-overlay overlay)))))) (defun gnus-cite-parse-wrapper () ;; Wrap chopped gnus-cite-parse. @@ -696,7 +727,7 @@ See also the documentation for `gnus-article-highlight-citation'." ;; Each line. (setq begin (point) guess-limit (progn (skip-chars-forward "^> \t\r\n") (point)) - end (progn (beginning-of-line 2) (point)) + end (point-at-bol 2) start end) (goto-char begin) ;; Ignore standard Supercite attribution prefix. @@ -712,7 +743,7 @@ See also the documentation for `gnus-article-highlight-citation'." ;; Each prefix. (setq end (match-end 0) prefix (buffer-substring begin end)) - (gnus-set-text-properties 0 (length prefix) nil prefix) + (set-text-properties 0 (length prefix) nil prefix) (setq entry (assoc prefix alist)) (if entry (setcdr entry (cons line (cdr entry))) @@ -720,9 +751,19 @@ See also the documentation for `gnus-article-highlight-citation'." (goto-char begin)) (goto-char start) (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))) + (push (cons "" entry) alist)) ;; We got all the potential prefixes. Now create ;; `gnus-cite-prefix-alist' containing the oldest prefix for each - ;; line that appears at least gnus-cite-minimum-match-count + ;; line that appears at least `gnus-cite-minimum-match-count' ;; times. First sort them by length. Longer is older. (setq alist (sort alist (lambda (a b) (> (length (car a)) (length (car b)))))) @@ -784,11 +825,10 @@ See also the documentation for `gnus-article-highlight-citation'." (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)))))))) + (when (not (assoc al al-alist)) + (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 @@ -968,8 +1008,7 @@ See also the documentation for `gnus-article-highlight-citation'." gnus-hidden-properties)) ((assq number gnus-cite-attribution-alist)) (t - (or (memq 'cite gnus-article-wash-types) - (push 'cite gnus-article-wash-types)) + (gnus-add-wash-type 'cite) (gnus-add-text-properties (point) (progn (forward-line 1) (point)) (nconc (list 'article-type 'cite) @@ -999,12 +1038,24 @@ See also the documentation for `gnus-article-highlight-citation'." (while vars (make-local-variable (pop vars))))) +(defun gnus-cited-line-p () + "Say whether the current line is a cited line." + (save-excursion + (beginning-of-line) + (let ((found nil)) + (dolist (prefix (mapcar 'car gnus-cite-prefix-alist)) + (when (string= (buffer-substring (point) (+ (length prefix) (point))) + prefix) + (setq found t))) + found))) + (gnus-ems-redefine) (provide 'gnus-cite) ;; Local Variables: -;; buffer-file-coding-system: iso-8859-1 +;; coding: iso-8859-1 ;; End: +;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a ;;; gnus-cite.el ends here