;;; gnus-cite.el --- parse citations in articles for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 1995-2011 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
- gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-11)
+ gnus-cite-7 gnus-cite-8 gnus-cite-9 gnus-cite-10 gnus-cite-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
- :type '(repeat face))
+ :type '(repeat face)
+ :set (lambda (symbol value)
+ (prog1
+ (custom-set-default symbol value)
+ (if (boundp 'gnus-message-max-citation-depth)
+ (setq gnus-message-max-citation-depth (length value)))
+ (if (boundp 'gnus-message-citation-keywords)
+ (setq gnus-message-citation-keywords
+ `((gnus-message-search-citation-line
+ ,@(let ((list nil)
+ (count 1))
+ (dolist (face value (nreverse list))
+ (push (list count (list 'quote face) 'prepend t)
+ list)
+ (setq count (1+ count)))))))))))
(defcustom gnus-cite-hide-percentage 50
"Only hide excess citation if above this percentage of the body."
;;; Commands:
-(defun gnus-article-highlight-citation (&optional force)
+(defun gnus-article-highlight-citation (&optional force same-buffer)
"Highlight cited text.
Each citation in the article will be highlighted with a different face.
The faces are taken from `gnus-cite-face-list'.
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
- (save-excursion
- (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)
(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)
(setq m (cdr m))))
marks))))
-(defun gnus-article-fill-cited-article (&optional force width)
+(defun gnus-article-fill-cited-long-lines ()
+ (gnus-article-fill-cited-article nil t))
+
+(defun gnus-article-fill-cited-article (&optional width long-lines)
"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)
+If WIDTH (the numerical prefix), use that text width when
+filling. If LONG-LINES, only fill sections that have lines
+longer than the frame width."
+ (interactive "P")
+ (with-current-buffer gnus-article-buffer
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(marks (gnus-dissect-cited-text))
(fill-prefix
(if (string= (cdar marks) "") ""
(concat (cdar marks) " ")))
+ (do-fill (not long-lines))
use-hard-newlines)
- (fill-region (point-min) (point-max)))
+ (unless do-fill
+ (setq do-fill (gnus-article-foldable-buffer (cdar marks))))
+ ;; Note: the XEmacs version of `fill-region' inserts a newline
+ ;; unless the region ends with a newline.
+ (when do-fill
+ (if (not long-lines)
+ (fill-region (point-min) (point-max))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (end-of-line)
+ (when (prog1
+ (> (current-column) (window-width))
+ (forward-line 1))
+ (save-restriction
+ (narrow-to-region (line-beginning-position 0) (point))
+ (fill-region (point-min) (point-max))))))))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
(when marks
gnus-cite-loose-attribution-alist nil
gnus-cite-article nil)))))
+(defun gnus-article-foldable-buffer (prefix)
+ (let ((do-fill nil)
+ columns)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (unless (> (length prefix) (- (point-max) (point)))
+ (forward-char (length prefix)))
+ (skip-chars-forward " \t")
+ (unless (eolp)
+ (let ((elem (assq (current-column) columns)))
+ (unless elem
+ (setq elem (cons (current-column) 0))
+ (push elem columns))
+ (setcdr elem (1+ (cdr elem)))))
+ (end-of-line)
+ (when (> (current-column) (window-width))
+ (setq do-fill t))
+ (forward-line 1))
+ (and do-fill
+ ;; We know know that there are long lines here, but does this look
+ ;; like code? Check for ragged edges on the left.
+ (< (length columns) 3))))
+
(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'.
(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
+ &n
projects / gnus / blobdiff