Commit 231f989b authored by Lars Magne Ingebrigtsen's avatar Lars Magne Ingebrigtsen
Browse files

New version.

parent b8c631a5
...@@ -68,15 +68,50 @@ ...@@ -68,15 +68,50 @@
;;; Code: ;;; Code:
(eval-when-compile
(require 'cl))
;;; Compatibility: ;;; Compatibility:
(or (fboundp 'buffer-substring-no-properties) (defun custom-xmas-add-text-properties (start end props &optional object)
;; Introduced in Emacs 19.29. (add-text-properties start end props object)
(defun buffer-substring-no-properties (beg end) (put-text-property start end 'start-open t object)
"Return the text from BEG to END, without text properties, as a string." (put-text-property start end 'end-open t object))
(let ((string (buffer-substring beg end)))
(set-text-properties 0 (length string) nil string) (defun custom-xmas-put-text-property (start end prop value &optional object)
string))) (put-text-property start end prop value object)
(put-text-property start end 'start-open t object)
(put-text-property start end 'end-open t object))
(defun custom-xmas-extent-start-open ()
(map-extents (lambda (extent arg)
(set-extent-property extent 'start-open t))
nil (point) (min (1+ (point)) (point-max))))
(if (string-match "XEmacs\\|Lucid" emacs-version)
(progn
(fset 'custom-add-text-properties 'custom-xmas-add-text-properties)
(fset 'custom-put-text-property 'custom-xmas-put-text-property)
(fset 'custom-extent-start-open 'custom-xmas-extent-start-open)
(fset 'custom-set-text-properties
(if (fboundp 'set-text-properties)
'set-text-properties))
(fset 'custom-buffer-substring-no-properties
(if (fboundp 'buffer-substring-no-properties)
'buffer-substring-no-properties
'custom-xmas-buffer-substring-no-properties)))
(fset 'custom-add-text-properties 'add-text-properties)
(fset 'custom-put-text-property 'put-text-property)
(fset 'custom-extent-start-open 'ignore)
(fset 'custom-set-text-properties 'set-text-properties)
(fset 'custom-buffer-substring-no-properties
'buffer-substring-no-properties))
(defun custom-xmas-buffer-substring-no-properties (beg end)
"Return the text from BEG to END, without text properties, as a string."
(let ((string (buffer-substring beg end)))
(custom-set-text-properties 0 (length string) nil string)
string))
(or (fboundp 'add-to-list) (or (fboundp 'add-to-list)
;; Introduced in Emacs 19.29. ;; Introduced in Emacs 19.29.
...@@ -171,16 +206,14 @@ STRING should be given if the last search was by `string-match' on STRING." ...@@ -171,16 +206,14 @@ STRING should be given if the last search was by `string-match' on STRING."
(and (fboundp 'set-face-underline-p) (and (fboundp 'set-face-underline-p)
(funcall 'set-face-underline-p 'underline t)))) (funcall 'set-face-underline-p 'underline t))))
(or (fboundp 'set-text-properties) (defun custom-xmas-set-text-properties (start end props &optional buffer)
;; Missing in XEmacs 19.12. (if (null buffer)
(defun set-text-properties (start end props &optional buffer) (if props
(if (or (null buffer) (bufferp buffer)) (while props
(if props (custom-put-text-property
(while props start end (car props) (nth 1 props) buffer)
(put-text-property (setq props (nthcdr 2 props)))
start end (car props) (nth 1 props) buffer) (remove-text-properties start end ()))))
(setq props (nthcdr 2 props)))
(remove-text-properties start end ())))))
(or (fboundp 'event-point) (or (fboundp 'event-point)
;; Missing in Emacs 19.29. ;; Missing in Emacs 19.29.
...@@ -201,60 +234,6 @@ into the buffer visible in the event's window." ...@@ -201,60 +234,6 @@ into the buffer visible in the event's window."
(defvar custom-mouse-face nil) (defvar custom-mouse-face nil)
(defvar custom-field-active-face nil)) (defvar custom-field-active-face nil))
(or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
;; Introduced in Emacs 19.29. Incompatible definition also introduced
;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
;; face-lock does not call modify-face, so we can safely redefine it.
(defun modify-face (face foreground background stipple
bold-p italic-p underline-p)
"Change the display attributes for face FACE.
FOREGROUND and BACKGROUND should be color strings or nil.
STIPPLE should be a stipple pattern name or nil.
BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
in italic, and underlined, respectively. (Yes if non-nil.)
If called interactively, prompts for a face and face attributes."
(interactive
(let* ((completion-ignore-case t)
(face (symbol-name (read-face-name "Modify face: ")))
(colors (mapcar 'list x-colors))
(stipples (mapcar 'list
(apply 'nconc
(mapcar 'directory-files
x-bitmap-file-path))))
(foreground (modify-face-read-string
face (face-foreground (intern face))
"foreground" colors))
(background (modify-face-read-string
face (face-background (intern face))
"background" colors))
(stipple (modify-face-read-string
face (face-stipple (intern face))
"stipple" stipples))
(bold-p (y-or-n-p (concat "Set face " face " bold ")))
(italic-p (y-or-n-p (concat "Set face " face " italic ")))
(underline-p (y-or-n-p (concat "Set face " face " underline "))))
(message "Face %s: %s" face
(mapconcat 'identity
(delq nil
(list (and foreground (concat (downcase foreground) " foreground"))
(and background (concat (downcase background) " background"))
(and stipple (concat (downcase stipple) " stipple"))
(and bold-p "bold") (and italic-p "italic")
(and underline-p "underline"))) ", "))
(list (intern face) foreground background stipple
bold-p italic-p underline-p)))
(condition-case nil (set-face-foreground face foreground) (error nil))
(condition-case nil (set-face-background face background) (error nil))
(condition-case nil (set-face-stipple face stipple) (error nil))
(if (string-match "XEmacs" emacs-version)
(progn
(funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
(funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
(funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
(funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
(set-face-underline-p face underline-p)
(and (interactive-p) (redraw-display))))
;; We can't easily check for a working intangible. ;; We can't easily check for a working intangible.
(defconst intangible (if (and (boundp 'emacs-minor-version) (defconst intangible (if (and (boundp 'emacs-minor-version)
(or (> emacs-major-version 19) (or (> emacs-major-version 19)
...@@ -281,9 +260,10 @@ If called interactively, prompts for a face and face attributes." ...@@ -281,9 +260,10 @@ If called interactively, prompts for a face and face attributes."
;; Put it in the Help menu, if possible. ;; Put it in the Help menu, if possible.
(if (string-match "XEmacs" emacs-version) (if (string-match "XEmacs" emacs-version)
;; XEmacs (disabled because it doesn't work) (if (featurep 'menubar)
(and current-menubar ;; XEmacs (disabled because it doesn't work)
(add-menu-item '("Help") "Customize..." 'customize nil)) (and current-menubar
(add-menu-item '("Help") "Customize..." 'customize t)))
;; Emacs 19.28 and earlier ;; Emacs 19.28 and earlier
(global-set-key [ menu-bar help customize ] (global-set-key [ menu-bar help customize ]
'("Customize..." . customize)) '("Customize..." . customize))
...@@ -359,7 +339,7 @@ If called interactively, prompts for a face and face attributes." ...@@ -359,7 +339,7 @@ If called interactively, prompts for a face and face attributes."
(defun custom-category-set (from to category) (defun custom-category-set (from to category)
"Make text between FROM and TWO have category CATEGORY." "Make text between FROM and TWO have category CATEGORY."
(put-text-property from to 'category category))) (custom-put-text-property from to 'category category)))
;;; External Data: ;;; External Data:
;; ;;
...@@ -419,7 +399,7 @@ If called interactively, prompts for a face and face attributes." ...@@ -419,7 +399,7 @@ If called interactively, prompts for a face and face attributes."
;; where each CUSTOM is a leaf in the hierarchy defined by the `type' ;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
;; property and `custom-type-properties'. ;; property and `custom-type-properties'.
(defvar custom-file (convert-standard-filename "~/.custom.el") (defvar custom-file "~/.custom.el"
"Name of file with customization information.") "Name of file with customization information.")
(defconst custom-data (defconst custom-data
...@@ -1080,6 +1060,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value." ...@@ -1080,6 +1060,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(end (make-marker)) (end (make-marker))
(data (vector repeat nil start end)) (data (vector repeat nil start end))
field) field)
(custom-extent-start-open)
(insert-before-markers "\n") (insert-before-markers "\n")
(backward-char 1) (backward-char 1)
(set-marker start (point)) (set-marker start (point))
...@@ -1309,7 +1290,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value." ...@@ -1309,7 +1290,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(face-tag (custom-face-tag custom)) (face-tag (custom-face-tag custom))
current) current)
(if face-tag (if face-tag
(put-text-property from (+ from (length (custom-tag custom))) (custom-put-text-property from (+ from (length (custom-tag custom)))
'face (funcall face-tag field value))) 'face (funcall face-tag field value)))
(if original (if original
(custom-field-original-set field value)) (custom-field-original-set field value))
...@@ -1395,9 +1376,10 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value." ...@@ -1395,9 +1376,10 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
() ()
(setq begin (point) (setq begin (point)
found (custom-insert (custom-property custom 'none) nil)) found (custom-insert (custom-property custom 'none) nil))
(add-text-properties begin (point) (custom-add-text-properties
(list rear-nonsticky t begin (point)
'face custom-field-uninitialized-face))) (list rear-nonsticky t
'face custom-field-uninitialized-face)))
(or original (or original
(custom-field-original-set found (custom-field-original field))) (custom-field-original-set found (custom-field-original field)))
(custom-field-accept found value original) (custom-field-accept found value original)
...@@ -1483,7 +1465,8 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value." ...@@ -1483,7 +1465,8 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(defun custom-face-import (custom value) (defun custom-face-import (custom value)
"Modify CUSTOM's VALUE to match internal expectations." "Modify CUSTOM's VALUE to match internal expectations."
(let ((name (symbol-name value))) (let ((name (or (and (facep value) (symbol-name (face-name value)))
(symbol-name value))))
(list (if (string-match "\ (list (if (string-match "\
custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
name) name)
...@@ -1496,9 +1479,8 @@ custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" ...@@ -1496,9 +1479,8 @@ custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
(intern (match-string 6 name))) (intern (match-string 6 name)))
value)))) value))))
(defun custom-face-lookup (fg bg stipple bold italic underline) (defun custom-face-lookup (&optional fg bg stipple bold italic underline)
"Lookup or create a face with specified attributes. "Lookup or create a face with specified attributes."
FG BG STIPPLE BOLD ITALIC UNDERLINE"
(let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
(or fg "default") (or fg "default")
(or bg "default") (or bg "default")
...@@ -1507,12 +1489,37 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE" ...@@ -1507,12 +1489,37 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(if (and (custom-facep name) (if (and (custom-facep name)
(fboundp 'make-face)) (fboundp 'make-face))
() ()
(make-face name) (copy-face 'default name)
(modify-face name (when (and fg
(if (string-equal fg "default") nil fg) (not (string-equal fg "default")))
(if (string-equal bg "default") nil bg) (condition-case ()
(if (string-equal stipple "default") nil stipple) (set-face-foreground name fg)
bold italic underline)) (error nil)))
(when (and bg
(not (string-equal bg "default")))
(condition-case ()
(set-face-background name bg)
(error nil)))
(when (and stipple
(not (string-equal stipple "default"))
(not (eq stipple 'custom:asis))
(fboundp 'set-face-stipple))
(set-face-stipple name stipple))
(when (and bold
(not (eq bold 'custom:asis)))
(condition-case ()
(make-face-bold name)
(error nil)))
(when (and italic
(not (eq italic 'custom:asis)))
(condition-case ()
(make-face-italic name)
(error nil)))
(when (and underline
(not (eq underline 'custom:asis)))
(condition-case ()
(set-face-underline-p name t)
(error nil))))
name)) name))
(defun custom-face-hack (field value) (defun custom-face-hack (field value)
...@@ -1528,7 +1535,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE" ...@@ -1528,7 +1535,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(face (custom-field-face field)) (face (custom-field-face field))
(from (point))) (from (point)))
(custom-text-insert (custom-tag custom)) (custom-text-insert (custom-tag custom))
(add-text-properties from (point) (custom-add-text-properties from (point)
(list 'face face (list 'face face
rear-nonsticky t)) rear-nonsticky t))
(custom-documentation-insert custom) (custom-documentation-insert custom)
...@@ -1539,7 +1546,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE" ...@@ -1539,7 +1546,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
"Update face of FIELD." "Update face of FIELD."
(let ((from (custom-field-start field)) (let ((from (custom-field-start field))
(custom (custom-field-custom field))) (custom (custom-field-custom field)))
(put-text-property from (+ from (length (custom-tag custom))) (custom-put-text-property from (+ from (length (custom-tag custom)))
'face (custom-field-face field)))) 'face (custom-field-face field))))
(defun custom-const-valid (custom value) (defun custom-const-valid (custom value)
...@@ -1828,9 +1835,9 @@ If the optional argument SAVE is non-nil, use that for saving changes." ...@@ -1828,9 +1835,9 @@ If the optional argument SAVE is non-nil, use that for saving changes."
(let ((from (point))) (let ((from (point)))
(insert tag) (insert tag)
(custom-category-set from (point) 'custom-button-properties) (custom-category-set from (point) 'custom-button-properties)
(put-text-property from (point) 'custom-tag field) (custom-put-text-property from (point) 'custom-tag field)
(if data (if data
(add-text-properties from (point) (list 'custom-data data))))) (custom-add-text-properties from (point) (list 'custom-data data)))))
(defun custom-documentation-insert (custom &rest ignore) (defun custom-documentation-insert (custom &rest ignore)
"Insert documentation from CUSTOM in current buffer." "Insert documentation from CUSTOM in current buffer."
...@@ -1849,11 +1856,13 @@ If the optional argument SAVE is non-nil, use that for saving changes." ...@@ -1849,11 +1856,13 @@ If the optional argument SAVE is non-nil, use that for saving changes."
"Describe how to execute COMMAND." "Describe how to execute COMMAND."
(let ((from (point))) (let ((from (point)))
(insert "`" (key-description (where-is-internal command nil t)) "'") (insert "`" (key-description (where-is-internal command nil t)) "'")
(set-text-properties from (point) (custom-set-text-properties from (point)
(list 'face custom-button-face (list 'face custom-button-face
mouse-face custom-mouse-face mouse-face custom-mouse-face
'custom-jump t ;Make TAB jump over it. 'custom-jump t ;Make TAB jump over it.
'custom-tag command)) 'custom-tag command
'start-open t
'end-open t))
(custom-category-set from (point) 'custom-documentation-properties)) (custom-category-set from (point) 'custom-documentation-properties))
(custom-help-insert ": " (custom-first-line (documentation command)) "\n")) (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
...@@ -2175,17 +2184,18 @@ If the optional argument is non-nil, show text iff the argument is positive." ...@@ -2175,17 +2184,18 @@ If the optional argument is non-nil, show text iff the argument is positive."
(insert-char (custom-padding custom) (insert-char (custom-padding custom)
(- (custom-width custom) (- (point) from))) (- (custom-width custom) (- (point) from)))
(custom-field-move field from (point)) (custom-field-move field from (point))
(set-text-properties (custom-set-text-properties
from (point) from (point)
(list 'custom-field field (list 'custom-field field
'custom-tag field 'custom-tag field
'face (custom-field-face field) 'face (custom-field-face field)
front-sticky t)))) 'start-open t
'end-open t))))
(defun custom-field-read (field) (defun custom-field-read (field)
;; Read the screen content of FIELD. ;; Read the screen content of FIELD.
(custom-read (custom-field-custom field) (custom-read (custom-field-custom field)
(buffer-substring-no-properties (custom-field-start field) (custom-buffer-substring-no-properties (custom-field-start field)
(custom-field-end field)))) (custom-field-end field))))
;; Fields are shown in a special `active' face when point is inside ;; Fields are shown in a special `active' face when point is inside
...@@ -2196,7 +2206,7 @@ If the optional argument is non-nil, show text iff the argument is positive." ...@@ -2196,7 +2206,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
;; Deactivate FIELD. ;; Deactivate FIELD.
(let ((before-change-functions nil) (let ((before-change-functions nil)
(after-change-functions nil)) (after-change-functions nil))
(put-text-property (custom-field-start field) (custom-field-end field) (custom-put-text-property (custom-field-start field) (custom-field-end field)
'face (custom-field-face field)))) 'face (custom-field-face field))))
(defun custom-field-enter (field) (defun custom-field-enter (field)
...@@ -2214,7 +2224,7 @@ If the optional argument is non-nil, show text iff the argument is positive." ...@@ -2214,7 +2224,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(setq pos (1- pos))) (setq pos (1- pos)))
(if (< pos (point)) (if (< pos (point))
(goto-char pos)))) (goto-char pos))))
(put-text-property start end 'face custom-field-active-face))) (custom-put-text-property start end 'face custom-field-active-face)))
(defun custom-field-resize (field) (defun custom-field-resize (field)
;; Resize FIELD after change. ;; Resize FIELD after change.
...@@ -2296,7 +2306,7 @@ If the optional argument is non-nil, show text iff the argument is positive." ...@@ -2296,7 +2306,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(let ((field custom-field-was)) (let ((field custom-field-was))
(custom-assert '(prog1 field (setq custom-field-was nil))) (custom-assert '(prog1 field (setq custom-field-was nil)))
;; Prevent mixing fields properties. ;; Prevent mixing fields properties.
(put-text-property begin end 'custom-field field) (custom-put-text-property begin end 'custom-field field)
;; Update the field after modification. ;; Update the field after modification.
(if (eq (custom-field-property begin) field) (if (eq (custom-field-property begin) field)
(let ((field-end (custom-field-end field))) (let ((field-end (custom-field-end field)))
......
This diff is collapsed.
;;; gnus-cite.el --- parse citations in articles for Gnus ;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk> ;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, mail ;; Keywords: news, mail
...@@ -29,13 +28,19 @@ ...@@ -29,13 +28,19 @@
(require 'gnus) (require 'gnus)
(require 'gnus-msg) (require 'gnus-msg)
(require 'gnus-ems) (require 'gnus-ems)
(eval-when-compile (require 'cl))
(eval-and-compile (eval-and-compile
(autoload 'gnus-article-add-button "gnus-vis") (autoload 'gnus-article-add-button "gnus-vis"))
)
;;; Customization: ;;; 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 (defvar gnus-cite-parse-max-size 25000
"Maximum article size (in bytes) where parsing citations is allowed. "Maximum article size (in bytes) where parsing citations is allowed.
Set it to nil to parse all articles.") Set it to nil to parse all articles.")
...@@ -45,20 +50,20 @@ 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.") "Regexp matching the longest possible citation prefix on a line.")
(defvar gnus-cite-max-prefix 20 (defvar gnus-cite-max-prefix 20
"Maximal possible length for a citation prefix.") "Maximum possible length for a citation prefix.")
(defvar gnus-supercite-regexp (defvar gnus-supercite-regexp
(concat "^\\(" gnus-cite-prefix-regexp "\\)? *" (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
">>>>> +\"\\([^\"\n]+\\)\" +==") ">>>>> +\"\\([^\"\n]+\\)\" +==")
"Regexp matching normal SuperCite attribution lines. "Regexp matching normal Supercite attribution lines.
The first regexp group should match a prefix added by another package.") The first grouping must match prefixes added by other packages.")
(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +==" (defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
"Regexp matching mangled SuperCite attribution lines. "Regexp matching mangled Supercite attribution lines.
The first regexp group should match the SuperCite attribution.") The first regexp group should match the Supercite attribution.")
(defvar gnus-cite-minimum-match-count 2 (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 ;see gnus-cus.el
;(defvar gnus-cite-face-list ;(defvar gnus-cite-face-list
...@@ -78,7 +83,7 @@ The first regexp group should match the SuperCite attribution.") ...@@ -78,7 +83,7 @@ The first regexp group should match the SuperCite attribution.")
(defvar gnus-cite-attribution-prefix "in article\\|in <" (defvar gnus-cite-attribution-prefix "in article\\|in <"
"Regexp matching the beginning of an attribution line.") "Regexp matching the beginning of an attribution line.")
(defvar gnus-cite-attribution-postfix (defvar gnus-cite-attribution-suffix
"\\(wrote\\|writes\\|said\\|says\\):[ \t]*$" "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
"Regexp matching the end of an attribution line. "Regexp matching the end of an attribution line.
The text matching the first grouping will be used as a button.") 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.") ...@@ -112,9 +117,7 @@ The text matching the first grouping will be used as a button.")
;;; Internal Variables: ;;; Internal Variables:
(defvar gnus-article-length nil) (defvar gnus-cite-article nil)
;; Length of article last time we parsed it.
;; BUG! KLUDGE! UGLY! FIX ME!
(defvar gnus-cite-prefix-alist nil) (defvar gnus-cite-prefix-alist nil)
;; Alist of citation prefixes. ;; Alist of citation prefixes.
...@@ -135,7 +138,13 @@ The text matching the first grouping will be used as a button.") ...@@ -135,7 +138,13 @@ The text matching the first grouping will be used as a button.")
;; WROTE: is the attribution line number ;; WROTE: is the attribution line number
;; IN: is the line number of the previous line if part of the same attribution, ;; 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 ;; 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: ;;; Commands:
...@@ -149,7 +158,7 @@ corresponding citation merged with `gnus-cite-attribution-face'. ...@@ -149,7 +158,7 @@ corresponding citation merged with `gnus-cite-attribution-face'.
Text is considered cited if at least `gnus-cite-minimum-match-count' Text is considered cited if at least `gnus-cite-minimum-match-count'
lines matches `gnus-cite-prefix-regexp' with the same prefix. 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." `gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force)) (interactive (list 'force))
;; Create dark or light faces if necessary. ;; Create dark or light faces if necessary.
...@@ -193,7 +202,7 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps ...@@ -193,7 +202,7 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
face (cdr (assoc prefix face-alist))) face (cdr (assoc prefix face-alist)))
;; Add attribution button. ;; Add attribution button.
(goto-line number) (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)) (save-excursion (end-of-line 1) (point))
t) t)
(gnus-article-add-button (match-beginning 1) (match-end 1) (gnus-article-add-button (match-beginning 1) (match-end 1)
...@@ -210,76 +219,203 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps ...@@ -210,76 +219,203 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
skip (gnus-cite-find-prefix number)) skip (gnus-cite-find-prefix number))
(gnus-cite-add-face number skip gnus-cite-attribution-face))))) (gnus-cite-add-face number skip gnus-cite-attribution-face)))))
(defun gnus-article-hide-citation (&optional force) (defun gnus-dissect-cited-text ()
"Hide all cited text except attribution lines. "Dissect the article buffer looking for cited text."
See the documentation for `gnus-article-highlight-citation'."
(interactive (list 'force))
(save-excursion (save-excursion
(set-buffer gnus-article-buffer) (set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force) (gnus-cite-parse-maybe)
(let ((buffer-read-only nil) (let ((alist gnus-cite-prefix-alist)
(alist gnus-cite-prefix-alist) prefix numbers number marks m)
(inhibit-point-motion-hooks t)