X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-cite.el;h=7419cedac5f1f05955a67144b8e21f5c57af077e;hp=5c2c033b06c66801f7130fe8fe63e5a4838c804b;hb=a2556858067503fc6719a777279ace07db95735e;hpb=a265806a4a019ae490789204e261351e3f334fff diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el index 5c2c033b0..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 . ;;; 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))))) @@ -1069,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))) @@ -1170,10 +1190,9 @@ 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 - (defvar font-lock-defaults-computed) - (defvar font-lock-keywords) - (defvar font-lock-set-defaults)) +(defvar font-lock-defaults-computed) +(defvar font-lock-keywords) +(defvar font-lock-set-defaults) (eval-and-compile (unless (featurep 'xemacs) @@ -1239,5 +1258,4 @@ is turned on." ;; coding: iso-8859-1 ;; End: -;;; arch-tag: 1997b044-6067-471e-8c8f-dc903093098a ;;; gnus-cite.el ends here