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

New version.

parent b8c631a5
......@@ -68,15 +68,50 @@
;;; Code:
(eval-when-compile
(require 'cl))
;;; Compatibility:
(or (fboundp 'buffer-substring-no-properties)
;; Introduced in Emacs 19.29.
(defun buffer-substring-no-properties (beg end)
(defun custom-xmas-add-text-properties (start end props &optional object)
(add-text-properties start end props object)
(put-text-property start end 'start-open t object)
(put-text-property start end 'end-open t object))
(defun custom-xmas-put-text-property (start end prop value &optional object)
(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)))
(set-text-properties 0 (length string) nil string)
string)))
(custom-set-text-properties 0 (length string) nil string)
string))
(or (fboundp 'add-to-list)
;; Introduced in Emacs 19.29.
......@@ -171,16 +206,14 @@ STRING should be given if the last search was by `string-match' on STRING."
(and (fboundp 'set-face-underline-p)
(funcall 'set-face-underline-p 'underline t))))
(or (fboundp 'set-text-properties)
;; Missing in XEmacs 19.12.
(defun set-text-properties (start end props &optional buffer)
(if (or (null buffer) (bufferp buffer))
(defun custom-xmas-set-text-properties (start end props &optional buffer)
(if (null buffer)
(if props
(while props
(put-text-property
(custom-put-text-property
start end (car props) (nth 1 props) buffer)
(setq props (nthcdr 2 props)))
(remove-text-properties start end ())))))
(remove-text-properties start end ()))))
(or (fboundp 'event-point)
;; Missing in Emacs 19.29.
......@@ -201,60 +234,6 @@ into the buffer visible in the event's window."
(defvar custom-mouse-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.
(defconst intangible (if (and (boundp 'emacs-minor-version)
(or (> emacs-major-version 19)
......@@ -281,9 +260,10 @@ If called interactively, prompts for a face and face attributes."
;; Put it in the Help menu, if possible.
(if (string-match "XEmacs" emacs-version)
(if (featurep 'menubar)
;; XEmacs (disabled because it doesn't work)
(and current-menubar
(add-menu-item '("Help") "Customize..." 'customize nil))
(add-menu-item '("Help") "Customize..." 'customize t)))
;; Emacs 19.28 and earlier
(global-set-key [ menu-bar help customize ]
'("Customize..." . customize))
......@@ -359,7 +339,7 @@ If called interactively, prompts for a face and face attributes."
(defun custom-category-set (from to 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:
;;
......@@ -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'
;; property and `custom-type-properties'.
(defvar custom-file (convert-standard-filename "~/.custom.el")
(defvar custom-file "~/.custom.el"
"Name of file with customization information.")
(defconst custom-data
......@@ -1080,6 +1060,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(end (make-marker))
(data (vector repeat nil start end))
field)
(custom-extent-start-open)
(insert-before-markers "\n")
(backward-char 1)
(set-marker start (point))
......@@ -1309,7 +1290,7 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(face-tag (custom-face-tag custom))
current)
(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)))
(if original
(custom-field-original-set field value))
......@@ -1395,7 +1376,8 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
()
(setq begin (point)
found (custom-insert (custom-property custom 'none) nil))
(add-text-properties begin (point)
(custom-add-text-properties
begin (point)
(list rear-nonsticky t
'face custom-field-uninitialized-face)))
(or original
......@@ -1483,7 +1465,8 @@ If optional ORIGINAL is non-nil, consider VALUE for the original value."
(defun custom-face-import (custom value)
"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 "\
custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
name)
......@@ -1496,9 +1479,8 @@ custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
(intern (match-string 6 name)))
value))))
(defun custom-face-lookup (fg bg stipple bold italic underline)
"Lookup or create a face with specified attributes.
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."
(let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
(or fg "default")
(or bg "default")
......@@ -1507,12 +1489,37 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(if (and (custom-facep name)
(fboundp 'make-face))
()
(make-face name)
(modify-face name
(if (string-equal fg "default") nil fg)
(if (string-equal bg "default") nil bg)
(if (string-equal stipple "default") nil stipple)
bold italic underline))
(copy-face 'default name)
(when (and fg
(not (string-equal fg "default")))
(condition-case ()
(set-face-foreground name fg)
(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))
(defun custom-face-hack (field value)
......@@ -1528,7 +1535,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
(face (custom-field-face field))
(from (point)))
(custom-text-insert (custom-tag custom))
(add-text-properties from (point)
(custom-add-text-properties from (point)
(list 'face face
rear-nonsticky t))
(custom-documentation-insert custom)
......@@ -1539,7 +1546,7 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE"
"Update face of FIELD."
(let ((from (custom-field-start 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))))
(defun custom-const-valid (custom value)
......@@ -1828,9 +1835,9 @@ If the optional argument SAVE is non-nil, use that for saving changes."
(let ((from (point)))
(insert tag)
(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
(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)
"Insert documentation from CUSTOM in current buffer."
......@@ -1849,11 +1856,13 @@ If the optional argument SAVE is non-nil, use that for saving changes."
"Describe how to execute COMMAND."
(let ((from (point)))
(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
mouse-face custom-mouse-face
'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-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."
(insert-char (custom-padding custom)
(- (custom-width custom) (- (point) from)))
(custom-field-move field from (point))
(set-text-properties
(custom-set-text-properties
from (point)
(list 'custom-field field
'custom-tag field
'face (custom-field-face field)
front-sticky t))))
'start-open t
'end-open t))))
(defun custom-field-read (field)
;; Read the screen content of 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))))
;; 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."
;; Deactivate FIELD.
(let ((before-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))))
(defun custom-field-enter (field)
......@@ -2214,7 +2224,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(setq pos (1- pos)))
(if (< pos (point))
(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)
;; Resize FIELD after change.
......@@ -2296,7 +2306,7 @@ If the optional argument is non-nil, show text iff the argument is positive."
(let ((field custom-field-was))
(custom-assert '(prog1 field (setq custom-field-was nil)))
;; 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.
(if (eq (custom-field-property begin) field)
(let ((field-end (custom-field-end field)))
......
This diff is collapsed.
;;; gnus-cite.el --- parse citations in articles for Gnus
;; Copyright (C) 1995 Free Software Foundation, Inc.
;; Copyright (C) 1995,96 Free Software Foundation, Inc.
;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; Keywords: news, mail
......@@ -29,13 +28,19 @@
(require 'gnus)
(require 'gnus-msg)
(require 'gnus-ems)
(eval-when-compile (require 'cl))
(eval-and-compile
(autoload 'gnus-article-add-button "gnus-vis")
)
(autoload 'gnus-article-add-button "gnus-vis"))
;;; 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
"Maximum article size (in bytes) where parsing citations is allowed.
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.")
(defvar gnus-cite-max-prefix 20
"Maximal possible length for a citation prefix.")
"Maximum possible length for a citation prefix.")
(defvar gnus-supercite-regexp
(concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
">>>>> +\"\\([^\"\n]+\\)\" +==")
"Regexp matching normal SuperCite attribution lines.
The first regexp group should match a prefix added by another package.")
"Regexp matching normal Supercite attribution lines.
The first grouping must match prefixes added by other packages.")
(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
"Regexp matching mangled SuperCite attribution lines.
The first regexp group should match the SuperCite attribution.")
"Regexp matching mangled Supercite attribution lines.
The first regexp group should match the Supercite attribution.")
(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
;(defvar gnus-cite-face-list
......@@ -78,7 +83,7 @@ The first regexp group should match the SuperCite attribution.")
(defvar gnus-cite-attribution-prefix "in article\\|in <"
"Regexp matching the beginning of an attribution line.")
(defvar gnus-cite-attribution-postfix
(defvar gnus-cite-attribution-suffix
"\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
"Regexp matching the end of an attribution line.
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:
(defvar gnus-article-length nil)
;; Length of article last time we parsed it.
;; BUG! KLUDGE! UGLY! FIX ME!
(defvar gnus-cite-article nil)
(defvar gnus-cite-prefix-alist nil)
;; Alist of citation prefixes.
......@@ -135,7 +138,13 @@ The text matching the first grouping will be used as a button.")
;; 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.
;; 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:
......@@ -149,7 +158,7 @@ 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-postfix' and perhaps
Lines matching `gnus-cite-attribution-suffix' and perhaps
`gnus-cite-attribution-prefix' are considered attribution lines."
(interactive (list 'force))
;; Create dark or light faces if necessary.
......@@ -193,7 +202,7 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
face (cdr (assoc prefix face-alist)))
;; Add attribution button.
(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))
t)
(gnus-article-add-button (match-beginning 1) (match-end 1)
......@@ -210,36 +219,151 @@ Lines matching `gnus-cite-attribution-postfix' and perhaps
skip (gnus-cite-find-prefix number))
(gnus-cite-add-face number skip gnus-cite-attribution-face)))))
(defun gnus-article-hide-citation (&optional force)
"Hide all cited text except attribution lines.
See the documentation for `gnus-article-highlight-citation'."
(interactive (list 'force))
(defun gnus-dissect-cited-text ()
"Dissect the article buffer looking for cited text."
(save-excursion
(set-buffer gnus-article-buffer)
(gnus-cite-parse-maybe force)
(let ((buffer-read-only nil)
(alist gnus-cite-prefix-alist)
(inhibit-point-motion-hooks t)
numbers number)
(gnus-cite-parse-maybe)
(let ((alist gnus-cite-prefix-alist)
prefix numbers number marks m)
;; Loop through citation prefixes.
(while alist
(setq numbers (cdr (car alist))
alist (cdr alist))
(setq numbers (pop alist)
prefix (pop numbers))
(while numbers
(setq number (car numbers)
numbers (cdr numbers))
(goto-line number)
(or (assq number gnus-cite-attribution-alist)
(add-text-properties (point) (progn (forward-line 1) (point))
gnus-hidden-properties)))))))
(defun gnus-article-hide-citation-maybe (&optional force)
"Hide cited text that has an attribution line.
(setq number (pop numbers))
(goto-char (point-min))
(forward-line number)
(push (cons (point-marker) "") marks)
(while (and numbers
(= (1- number) (car numbers)))
(setq number (pop numbers)))
(goto-char (point-min))
(forward-line (1- number))
(push (cons (point-marker) prefix) marks)))
(goto-char (point-min))
(search-forward "\n\n" nil t)
(push (cons (point-marker) "") marks)
(goto-char (point-max))
(re-search-backward gnus-signature-separator nil t)
(push (cons (point-marker) "") marks)
(setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
(let* ((omarks marks))
(setq marks nil)
(while (cdr omarks)
(if (= (caar omarks) (caadr omarks))
(progn
(unless (equal (cdar omarks) "")
(push (car omarks) marks))
(unless (equal (cdadr omarks) "")
(push (cadr omarks) marks))
(setq omarks (cdr omarks)))
(push (car omarks) marks))
(setq omarks (cdr omarks)))
(when (car omarks)
(push (car omarks) marks))
(setq marks (setq m (nreverse marks)))
(while (cddr m)
(if (and (equal (cdadr m) "")
(equal (cdar m) (cdaddr m))
(goto-char (caadr m))
(forward-line 1)
(= (point) (caaddr m)))
(setcdr m (cdddr m))
(setq m (cdr m))))
marks))))
(defun gnus-article-fill-cited-article (&optional force)
"Do word wrapping in the current article."
(interactive (list t))
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(inhibit-point-motion-hooks t)
(marks (gnus-dissect-cited-text))
(adaptive-fill-mode nil))
(save-restriction
(while (cdr marks)
(widen)
(narrow-to-region (caar marks) (caadr marks))
(let ((adaptive-fill-regexp
(concat "^" (regexp-quote (cdar marks)) " *"))
(fill-prefix (cdar marks)))
(fill-region (point-min) (point-max)))
(set-marker (caar marks) nil)
(setq marks (cdr marks)))
(when marks
(set-marker (caar marks) nil))))))
(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'.
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (append (gnus-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))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
(marks (gnus-dissect-cited-text))
(inhibit-point-motion-hooks t)
(props (nconc (list 'gnus-type 'cite)
gnus-hidden-properties))
beg end)
(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 gnus-cited-lines-visible)
(if (>= (point) end)
(setq beg nil)
(setq beg (point-marker))))
(when (and beg end)
(gnus-add-text-properties beg end props)
(goto-char beg)
(unless (save-excursion (search-backward "\n\n" nil t))
(insert "\n"))
(gnus-article-add-button
(point)
(progn (eval gnus-cited-text-button-line-format-spec) (point))
`gnus-article-toggle-cited-text (cons beg end))
(set-marker beg (point))))))))
(defun gnus-article-toggle-cited-text (region)
"Toggle hiding the text in REGION."
(let (buffer-read-only)
(funcall
(if (text-property-any
(car region) (1- (cdr region))
(car gnus-hidden-properties) (cadr gnus-hidden-properties))
'remove-text-properties 'gnus-add-text-properties)
(car region) (cdr region) gnus-hidden-properties)))
(defun gnus-article-hide-citation-maybe (&optional arg force)
"Toggle hiding of cited text that has an attribution line.
If given a negative prefix, always show; if given a positive prefix,
always hide.
This will do nothing unless at least `gnus-cite-hide-percentage'
percent and at least `gnus-cite-hide-absolute' lines of the body is
cited text with attributions. When called interactively, these two
variables are ignored.
See also the documentation for `gnus-article-highlight-citation'."
(interactive (list 'force))
(interactive (append (gnus-hidden-arg) (list 'force)))
(unless (gnus-article-check-hidden-text 'cite arg)
(save-excursion
(set-buffer gnus-article-buffer)