Commit 4ee1cf9f authored by Per Abrahamsen's avatar Per Abrahamsen
Browse files

Synched with 1.9951.

parent f8c39f51
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
;; Version: 1.9944
;; Version: 1.9951
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -773,6 +773,26 @@ If VARIABLE has a `custom-type' property, it must be a widget and the
(funcall (or (get var 'custom-set) 'set-default) var val)
(put var 'customized-value (list (custom-quote val))))
;;;###autoload
(defun customize-save-variable (var val)
"Set the default for VARIABLE to VALUE, and save it for future sessions.
If VARIABLE has a `custom-set' property, that is used for setting
VARIABLE, otherwise `set-default' is used.
The `customized-value' property of the VARIABLE will be set to a list
with a quoted VALUE as its sole list member.
If VARIABLE has a `variable-interactive' property, that is used as if
it were the arg to `interactive' (which see) to interactively read the value.
If VARIABLE has a `custom-type' property, it must be a widget and the
`:prompt-value' property of that widget will be used for reading the value. "
(interactive (custom-prompt-variable "Set and ave variable: "
"Set and save value for %s as: "))
(funcall (or (get var 'custom-set) 'set-default) var val)
(put var 'saved-value (list (custom-quote val)))
(custom-save-all))
;;;###autoload
(defun customize ()
"Select a customization buffer which you can use to set user options.
......@@ -1109,6 +1129,7 @@ Reset all values in this buffer to their standard settings."
options))))
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))
(message "Creating customization items %2d%%...done" 100)
(unless (eq custom-buffer-style 'tree)
(mapcar 'custom-magic-reset custom-options))
(message "Creating customization setup...")
......@@ -1119,45 +1140,46 @@ Reset all values in this buffer to their standard settings."
;;; The Tree Browser.
;;;###autoload
(defun customize-browse ()
(defun customize-browse (&optional group)
"Create a tree browser for the customize hierarchy."
(interactive)
(let ((group 'emacs))
(let ((name "*Customize Browser*"))
(kill-buffer (get-buffer-create name))
(switch-to-buffer (get-buffer-create name)))
(custom-mode)
(widget-insert "\
(unless group
(setq group 'emacs))
(let ((name "*Customize Browser*"))
(kill-buffer (get-buffer-create name))
(switch-to-buffer (get-buffer-create name)))
(custom-mode)
(widget-insert "\
Square brackets show active fields; type RET or click mouse-1
on an active field to invoke its action.
Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n")
(if custom-browse-only-groups
(widget-insert "\
(if custom-browse-only-groups
(widget-insert "\
Invoke the [Group] button below to edit that item in another window.\n\n")
(widget-insert "Invoke the ")
(widget-create 'item
:format "%t"
:tag "[Group]"
:tag-glyph "folder")
(widget-insert ", ")
(widget-create 'item
:format "%t"
:tag "[Face]"
:tag-glyph "face")
(widget-insert ", and ")
(widget-create 'item
:format "%t"
:tag "[Option]"
:tag-glyph "option")
(widget-insert " buttons below to edit that
(widget-insert "Invoke the ")
(widget-create 'item
:format "%t"
:tag "[Group]"
:tag-glyph "folder")
(widget-insert ", ")
(widget-create 'item
:format "%t"
:tag "[Face]"
:tag-glyph "face")
(widget-insert ", and ")
(widget-create 'item
:format "%t"
:tag "[Option]"
:tag-glyph "option")
(widget-insert " buttons below to edit that
item in another window.\n\n"))
(let ((custom-buffer-style 'tree))
(widget-create 'custom-group
:custom-last t
:custom-state 'unknown
:tag (custom-unlispify-tag-name group)
:value group))
(goto-char (point-min))))
(let ((custom-buffer-style 'tree))
(widget-create 'custom-group
:custom-last t
:custom-state 'unknown
:tag (custom-unlispify-tag-name group)
:value group))
(goto-char (point-min)))
(define-widget 'custom-browse-visibility 'item
"Control visibility of of items in the customize tree browser."
......@@ -2549,19 +2571,32 @@ and so forth. The remaining group tags are shown with
(insert "--------")))
(widget-default-create widget))
(defun custom-group-members (symbol groups-only)
"Return SYMBOL's custom group members.
If GROUPS-ONLY non-nil, return only those members that are groups."
(if (not groups-only)
(get symbol 'custom-group)
(let (members)
(dolist (entry (get symbol 'custom-group))
(when (eq (nth 1 entry) 'custom-group)
(push entry members)))
(nreverse members))))
(defun custom-group-value-create (widget)
"Insert a customize group for WIDGET in the current buffer."
(let ((state (widget-get widget :custom-state))
(level (widget-get widget :custom-level))
(indent (widget-get widget :indent))
(prefix (widget-get widget :custom-prefix))
(buttons (widget-get widget :buttons))
(tag (widget-get widget :tag))
(symbol (widget-value widget)))
(let* ((state (widget-get widget :custom-state))
(level (widget-get widget :custom-level))
(indent (widget-get widget :indent))
(prefix (widget-get widget :custom-prefix))
(buttons (widget-get widget :buttons))
(tag (widget-get widget :tag))
(symbol (widget-value widget))
(members (custom-group-members symbol
(and (eq custom-buffer-style 'tree)
custom-browse-only-groups))))
(cond ((and (eq custom-buffer-style 'tree)
(eq state 'hidden)
(or (get symbol 'custom-group)
(custom-unloaded-widget-p widget)))
(or members (custom-unloaded-widget-p widget)))
(custom-browse-insert-prefix prefix)
(push (widget-create-child-and-convert
widget 'custom-browse-visibility
......@@ -2576,7 +2611,7 @@ and so forth. The remaining group tags are shown with
(insert " " tag "\n")
(widget-put widget :buttons buttons))
((and (eq custom-buffer-style 'tree)
(zerop (length (get symbol 'custom-group))))
(zerop (length members)))
(custom-browse-insert-prefix prefix)
(insert "[ ]-- ")
;; (widget-glyph-insert nil "[ ]" "empty")
......@@ -2589,7 +2624,7 @@ and so forth. The remaining group tags are shown with
((eq custom-buffer-style 'tree)
(custom-browse-insert-prefix prefix)
(custom-load-widget widget)
(if (zerop (length (get symbol 'custom-group)))
(if (zerop (length members))
(progn
(custom-browse-insert-prefix prefix)
(insert "[ ]-- ")
......@@ -2613,7 +2648,7 @@ and so forth. The remaining group tags are shown with
(insert " " tag "\n")
(widget-put widget :buttons buttons)
(message "Creating group...")
(let* ((members (custom-sort-items (get symbol 'custom-group)
(let* ((members (custom-sort-items members
custom-browse-sort-alphabetically
custom-browse-order-groups))
(prefixes (widget-get widget :custom-prefixes))
......@@ -2626,18 +2661,16 @@ and so forth. The remaining group tags are shown with
(while members
(setq entry (car members)
members (cdr members))
(when (or (not custom-browse-only-groups)
(eq (nth 1 entry) 'custom-group))
(push (widget-create-child-and-convert
widget (nth 1 entry)
:group widget
:tag (custom-unlispify-tag-name (nth 0 entry))
:custom-prefixes custom-prefix-list
:custom-level (1+ level)
:custom-last (null members)
:value (nth 0 entry)
:custom-prefix prefix)
children)))
(push (widget-create-child-and-convert
widget (nth 1 entry)
:group widget
:tag (custom-unlispify-tag-name (nth 0 entry))
:custom-prefixes custom-prefix-list
:custom-level (1+ level)
:custom-last (null members)
:value (nth 0 entry)
:custom-prefix prefix)
children))
(widget-put widget :children (reverse children)))
(message "Creating group...done")))
;; Nested style.
......@@ -2732,7 +2765,7 @@ and so forth. The remaining group tags are shown with
;; Members.
(message "Creating group...")
(custom-load-widget widget)
(let* ((members (custom-sort-items (get symbol 'custom-group)
(let* ((members (custom-sort-items members
custom-buffer-sort-alphabetically
custom-buffer-order-groups))
(prefixes (widget-get widget :custom-prefixes))
......@@ -2870,8 +2903,11 @@ Optional EVENT is the location for the menu."
;;; The `custom-save-all' Function.
;;;###autoload
(defcustom custom-file (if (featurep 'xemacs)
"~/.xemacs-custom"
(defcustom custom-file (if (boundp 'emacs-user-extension-dir)
(concat "~"
init-file-user
emacs-user-extension-dir
"options.el")
"~/.emacs")
"File used for storing customization information.
If you change this from the default \"~/.emacs\" you need to
......@@ -2985,11 +3021,12 @@ Leave point at the location of the call, or after the last expression."
;;;###autoload
(defun custom-save-all ()
"Save all customizations in `custom-file'."
(custom-save-variables)
(custom-save-faces)
(save-excursion
(set-buffer (find-file-noselect custom-file))
(save-buffer)))
(let ((inhibit-read-only t))
(custom-save-variables)
(custom-save-faces)
(save-excursion
(set-buffer (find-file-noselect custom-file))
(save-buffer))))
;;; The Customize Menu.
......@@ -3148,6 +3185,9 @@ The following commands are available:
Move to next button or editable field. \\[widget-forward]
Move to previous button or editable field. \\[widget-backward]
\\<widget-field-keymap>\
Complete content of editable text field. \\[widget-complete]
\\<custom-mode-map>\
Invoke button under the mouse pointer. \\[Custom-move-and-invoke]
Invoke button under point. \\[widget-button-press]
Set all modifications. \\[Custom-set]
......
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.9945
;; Version: 1.9951
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -38,6 +38,7 @@
(eval-and-compile
(autoload 'pp-to-string "pp")
(autoload 'Info-goto-node "info")
(autoload 'finder-commentary "finder" nil t)
(when (string-match "XEmacs" emacs-version)
(condition-case nil
......@@ -101,27 +102,6 @@
(display-error obj buf)
(buffer-string buf)))))
(when (let ((a "foo"))
(put-text-property 1 2 'foo 1 a)
(put-text-property 1 2 'bar 2 a)
(set-text-properties 1 2 nil a)
(text-properties-at 1 a))
;; XEmacs 20.2 and earlier had a buggy set-text-properties.
(defun set-text-properties (start end props &optional buffer-or-string)
"Completely replace properties of text from START to END.
The third argument PROPS is the new property list.
The optional fourth argument, BUFFER-OR-STRING,
is the string or buffer containing the text."
(map-extents #'(lambda (extent ignored)
(remove-text-properties
start end
(list (extent-property extent 'text-prop)
nil)
buffer-or-string)
nil)
buffer-or-string start end nil nil 'text-prop)
(add-text-properties start end props buffer-or-string)))
;;; Customization.
(defgroup widgets nil
......@@ -352,18 +332,6 @@ minibuffer."
;;
;; These functions are for specifying text properties.
(defun widget-specify-none (from to)
;; Clear all text properties between FROM and TO.
(set-text-properties from to nil))
(defun widget-specify-text (from to)
;; Default properties.
(add-text-properties from to (list 'read-only t
'front-sticky t
'rear-nonsticky nil
'start-open nil
'end-open nil)))
(defcustom widget-field-add-space
(or (< emacs-major-version 20)
(and (eq emacs-major-version 20)
......@@ -378,9 +346,9 @@ size field."
:group 'widgets)
(defcustom widget-field-use-before-change
(or (> emacs-minor-version 34)
(>= emacs-major-version 20)
(string-match "XEmacs" emacs-version))
(and (or (> emacs-minor-version 34)
(> emacs-major-version 19))
(not (string-match "XEmacs" emacs-version)))
"Non-nil means use `before-change-functions' to track editable fields.
This enables the use of undo, but doesn't work on Emacs 19.34 and earlier.
Using before hooks also means that the :notify function can't know the
......@@ -390,7 +358,6 @@ new value."
(defun widget-specify-field (widget from to)
"Specify editable button for WIDGET between FROM and TO."
(put-text-property from to 'read-only nil)
;; Terminating space is not part of the field, but necessary in
;; order for local-map to work. Remove next sexp if local-map works
;; at the end of the overlay.
......@@ -401,14 +368,6 @@ new value."
(widget-field-add-space
(insert-and-inherit " ")))
(setq to (point)))
(if (or widget-field-add-space
(null (widget-get widget :size)))
(add-text-properties (1- to) to
'(front-sticky nil start-open t read-only to))
(add-text-properties to (1+ to)
'(front-sticky nil start-open t read-only to)))
(add-text-properties (1- from) from
'(rear-nonsticky t end-open t read-only from))
(let ((map (widget-get widget :keymap))
(face (or (widget-get widget :value-face) 'widget-field-face))
(help-echo (widget-get widget :help-echo))
......@@ -461,8 +420,10 @@ new value."
(defun widget-specify-doc (widget from to)
;; Specify documentation for WIDGET between FROM and TO.
(add-text-properties from to (list 'widget-doc widget
'face widget-documentation-face)))
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'widget-doc widget)
(overlay-put overlay 'face widget-documentation-face)
(widget-put widget :doc-overlay overlay)))
(defmacro widget-specify-insert (&rest form)
;; Execute FORM without inheriting any text properties.
......@@ -474,7 +435,6 @@ new value."
after-change-functions)
(insert "<>")
(narrow-to-region (- (point) 2) (point))
(widget-specify-none (point-min) (point-max))
(goto-char (1+ (point-min)))
(setq result (progn (,@ form)))
(delete-region (point-min) (1+ (point-min)))
......@@ -887,8 +847,7 @@ The optional ARGS are additional keyword arguments."
before-change-functions
after-change-functions
(from (point)))
(apply 'insert args)
(widget-specify-text from (point))))
(apply 'insert args)))
(defun widget-convert-text (type from to
&optional button-from button-to
......@@ -902,7 +861,6 @@ Optional ARGS are extra keyword arguments for TYPE."
(let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
(from (copy-marker from))
(to (copy-marker to)))
(widget-specify-text from to)
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
......@@ -925,6 +883,7 @@ button end points."
(to (widget-get widget :to))
(button (widget-get widget :button-overlay))
(sample (widget-get widget :sample-overlay))
(doc (widget-get widget :doc-overlay))
(field (widget-get widget :field-overlay))
(children (widget-get widget :children)))
(set-marker from nil)
......@@ -933,6 +892,8 @@ button end points."
(delete-overlay button))
(when sample
(delete-overlay sample))
(when doc
(delete-overlay doc))
(when field
(delete-overlay field))
(mapcar 'widget-leave-text children)))
......@@ -1126,6 +1087,12 @@ POS defaults to the value of (point)."
widget))
nil)))
(defcustom widget-use-overlay-change (string-match "XEmacs" emacs-version)
"If non-nil, use overlay change functions to tab around in the buffer.
This is much faster, but doesn't work reliably on Emacs 19.34."
:type 'boolean
:group 'widgets)
(defun widget-move (arg)
"Move point to the ARG next field or button.
ARG may be negative to move backward."
......@@ -1136,9 +1103,12 @@ ARG may be negative to move backward."
new)
;; Forward.
(while (> arg 0)
(if (eobp)
(goto-char (point-min))
(forward-char 1))
(cond ((eobp)
(goto-char (point-min)))
(widget-use-overlay-change
(goto-char (next-overlay-change (point))))
(t
(forward-char 1)))
(and (eq pos (point))
(eq arg number)
(error "No buttons or fields found"))
......@@ -1149,9 +1119,12 @@ ARG may be negative to move backward."
(setq old new)))))
;; Backward.
(while (< arg 0)
(if (bobp)
(goto-char (point-max))
(backward-char 1))
(cond ((bobp)
(goto-char (point-max)))
(widget-use-overlay-change
(goto-char (previous-overlay-change (point))))
(t
(backward-char 1)))
(and (eq pos (point))
(eq arg number)
(error "No buttons or fields found"))
......@@ -1187,7 +1160,9 @@ With optional ARG, move across that many fields."
(start (and field (widget-field-start field))))
(if (and start (not (eq start (point))))
(goto-char start)
(call-interactively 'beginning-of-line))))
(call-interactively 'beginning-of-line)))
;; XEmacs: preserve the region
(setq zmacs-region-stays t))
(defun widget-end-of-line ()
"Go to end of field or end of line, whichever is first."
......@@ -1196,7 +1171,9 @@ With optional ARG, move across that many fields."
(end (and field (widget-field-end field))))
(if (and end (not (eq end (point))))
(goto-char end)
(call-interactively 'end-of-line))))
(call-interactively 'end-of-line)))
;; XEmacs: preserve the region
(setq zmacs-region-stays t))
(defun widget-kill-line ()
"Kill to end of field or end of line, whichever is first."
......@@ -1250,14 +1227,7 @@ When not inside a field, move to the previous button or field."
(set-marker from nil)
(set-marker to nil))))
(widget-clear-undo)
;; We need to maintain text properties and size of the editing fields.
(make-local-variable 'after-change-functions)
(setq after-change-functions
(if widget-field-list '(widget-after-change) nil))
(when widget-field-use-before-change
(make-local-variable 'before-change-functions)
(setq before-change-functions
(if widget-field-list '(widget-before-change) nil))))
(widget-add-change))
(defvar widget-field-last nil)
;; Last field containing point.
......@@ -1302,13 +1272,29 @@ Unlike (get-char-property POS 'field) this, works with empty fields too."
(setq found field))))
found))
(defun widget-before-change (from &rest ignore)
(defun widget-before-change (from to)
;; This is how, for example, a variable changes its state to `modified'.
;; when it is being edited.
(condition-case nil
(let ((field (widget-field-find from)))
(widget-apply field :notify field))
(error (debug "Before Change"))))
(let ((from-field (widget-field-find from))
(to-field (widget-field-find to)))
(cond ((not (eq from-field to-field))
(add-hook 'post-command-hook 'widget-add-change nil t)
(error "Change should be restricted to a single field"))
((null from-field)
(add-hook 'post-command-hook 'widget-add-change nil t)
(error "Attempt to change text outside editable field"))
(widget-field-use-before-change
(condition-case nil
(widget-apply from-field :notify from-field)
(error (debug "Before Change")))))))
(defun widget-add-change ()
(make-local-hook 'post-command-hook)
(remove-hook 'post-command-hook 'widget-add-change t)
(make-local-hook 'before-change-functions)
(add-hook 'before-change-functions 'widget-before-change nil t)
(make-local-hook 'after-change-functions)
(add-hook 'after-change-functions 'widget-after-change nil t))
(defun widget-after-change (from to old)
;; Adjust field size and text properties.
......@@ -1504,7 +1490,6 @@ If that does not exists, call the value of `widget-complete-field'."
(widget-apply widget :value-create)))
(let ((from (copy-marker (point-min)))
(to (copy-marker (point-max))))
(widget-specify-text from to)
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
......@@ -1570,6 +1555,7 @@ If that does not exists, call the value of `widget-complete-field'."
(inactive-overlay (widget-get widget :inactive))
(button-overlay (widget-get widget :button-overlay))
(sample-overlay (widget-get widget :sample-overlay))
(doc-overlay (widget-get widget :doc-overlay))
before-change-functions
after-change-functions
(inhibit-read-only t))
......@@ -1580,6 +1566,8 @@ If that does not exists, call the value of `widget-complete-field'."
(delete-overlay button-overlay))
(when sample-overlay
(delete-overlay sample-overlay))
(when doc-overlay
(delete-overlay doc-overlay))
(when (< from to)
;; Kludge: this doesn't need to be true for empty formats.
(delete-region from to))
......@@ -1822,6 +1810,16 @@ If END is omitted, it defaults to the length of LIST."
"Find the Emacs Library file specified by WIDGET."
(find-file (locate-library (widget-value widget))))
;;; The `emacs-commentary-link' Widget.
(define-widget 'emacs-commentary-link 'link
"A link to Commentary in an Emacs Lisp library file."
:action 'widget-emacs-commentary-link-action)
(defun widget-emacs-commentary-link-action (widget &optional event)
"Find the Commentary section of the Emacs file specified by WIDGET."
(finder-commentary (widget-value widget)))
;;; The `editable-field' Widget.
(define-widget 'editable-field 'default
......@@ -2609,8 +2607,6 @@ when he invoked the menu."
(when (< (widget-get child :entry-from) (widget-get widget :from))
(set-marker (widget-get widget :from)
(widget-get child :entry-from)))
(widget-specify-text (widget-get child :entry-from)
(widget-get child :entry-to))
(if (eq (car children) before)
(widget-put widget :children (cons child children))
(while (not (eq (car (cdr children)) before))
......@@ -2684,7 +2680,6 @@ when he invoked the menu."
(widget-get widget :buttons))))
(let ((entry-from (copy-marker (point-min)))
(entry-to (copy-marker (point-max))))
(widget-specify-text entry-from entry-to)
(set-marker-insertion-type entry-from t)
(set-marker-insertion-type entry-to nil)
(widget-put child :entry-from entry-from)
......@@ -2943,7 +2938,8 @@ link for that string."
"A regular expression."
:match 'widget-regexp-match
:validate 'widget-regexp-validate
:value-face 'widget-single-line-field-face
;; Doesn't work well with terminating newline.
;; :value-face 'widget-single-line-field-face
:tag "Regexp")
(defun widget-regexp-match (widget value)
......@@ -2969,7 +2965,8 @@ It will read a file name from the minibuffer when invoked."
:complete-function 'widget-file-complete
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
:value-face 'widget-single-line-field-face
;; Doesn't work well with terminating newline.
;; :value-face 'widget-single-line-field-face
:tag "File")
(defun widget-file-complete ()
......@@ -3386,11 +3383,14 @@ To use this type, you must define :match or :match-alternatives."
(message "Making completion list...done")))))
(defun widget-color-sample-face-get (widget)
(let ((symbol (intern (concat "fg:" (widget-value widget)))))
(let* ((value (condition-case nil
(widget-value widget)
(error (widget-get widget :value))))
(symbol (intern (concat "fg:" value))))
(if (string-match "XEmacs" emacs-version)
(prog1 symbol
(or (find-face symbol)
(set-face-foreground (make-face symbol) (widget-value widget))))
(set-face-foreground (make-face symbol) value)))
(condition-case nil
(facemenu-get-face symbol)
(error 'default)))))
......@@ -3414,14 +3414,21 @@ To use this type, you must define :match or :match-alternatives."
;; Prompt for a color.
(let* ((tag (widget-apply widget :menu-tag-get))
(prompt (concat tag ": "))
(answer (cond ((string-match "XEmacs" emacs-version)
(read-color prompt))
((fboundp 'x-defined-colors)
(completing-read (concat tag ": ")
(widget-color-choice-list)
nil nil nil 'widget-color-history))
(t
(read-string prompt (widget-value widget))))))
(value (widget-value widget))
(start (widget-field-start widget))
(pos (cond ((< (point) start)
0)
((> (point) (+ start (length value)))