;;
;; 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.
(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.
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...")
;;; 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."
(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
(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")
((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 "[ ]-- ")
(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))
(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.
;; 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))
;;; 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
;;;###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.
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]
;;
;; 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.
(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
(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
;;
;; 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)
: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
(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.
(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))
(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.
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)))
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
(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)
(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)
(delete-overlay button))
(when sample
(delete-overlay sample))
+ (when doc
+ (delete-overlay doc))
(when field
(delete-overlay field))
(mapcar 'widget-leave-text children)))
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."
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"))
(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"))
(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."
(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."
(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.
(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.
(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)
(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))
(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))
"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
(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))
(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)
"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)
: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 ()
(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)))))
;; 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)))
+ (length value))
+ (t
+ (- (point) start))))
+ (answer (if (commandp 'read-color)
+ (read-color prompt)
+ (completing-read (concat tag ": ")
+ (widget-color-choice-list)
+ nil nil
+ (cons value pos)
+ 'widget-color-history))))
(unless (zerop (length answer))
(widget-value-set widget answer)
(widget-setup)
projects / emacs.git / commitdiff