;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.9929
+;; Version: 1.9936
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
:group 'customize
:group 'faces)
+(defgroup custom-browse nil
+ "Control customize browser."
+ :prefix "custom-"
+ :group 'customize)
+
(defgroup custom-buffer nil
- "Control the customize buffers."
+ "Control customize buffers."
:prefix "custom-"
:group 'customize)
(defgroup custom-menu nil
- "Control how the customize menus."
+ "Control customize menus."
:prefix "custom-"
:group 'customize)
;;; Sorting.
+(defcustom custom-browse-sort-alphabetically nil
+ "If non-nil, sort members of each customization group alphabetically."
+ :type 'boolean
+ :group 'custom-browse)
+
+(defcustom custom-browse-order-groups nil
+ "If non-nil, order group members within each customization group.
+If `first', order groups before non-groups.
+If `last', order groups after non-groups."
+ :type '(choice (const first)
+ (const last)
+ (const :tag "none" nil))
+ :group 'custom-browse)
+
(defcustom custom-buffer-sort-alphabetically nil
- "If non-nil, sort the members of each customization group alphabetically."
+ "If non-nil, sort members of each customization group alphabetically."
:type 'boolean
:group 'custom-buffer)
-(defcustom custom-buffer-groups-last nil
- "If non-nil, put subgroups after all ordinary options within a group."
- :type 'boolean
+(defcustom custom-buffer-order-groups 'last
+ "If non-nil, order group members within each customization group.
+If `first', order groups before non-groups.
+If `last', order groups after non-groups."
+ :type '(choice (const first)
+ (const last)
+ (const :tag "none" nil))
:group 'custom-buffer)
(defcustom custom-menu-sort-alphabetically nil
- "If non-nil, sort the members of each customization group alphabetically."
+ "If non-nil, sort members of each customization group alphabetically."
:type 'boolean
:group 'custom-menu)
-(defcustom custom-menu-groups-first t
- "If non-nil, put subgroups before all ordinary options within a group."
- :type 'boolean
+(defcustom custom-menu-order-groups 'first
+ "If non-nil, order group members within each customization group.
+If `first', order groups before non-groups.
+If `last', order groups after non-groups."
+ :type '(choice (const first)
+ (const last)
+ (const :tag "none" nil))
:group 'custom-menu)
-(defun custom-buffer-sort-predicate (a b)
- "Return t iff A should come before B in a customization buffer.
-A and B should be members of a `custom-group' property."
- (cond ((and (not custom-buffer-groups-last)
- (not custom-buffer-sort-alphabetically))
- nil)
- ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
- (not custom-buffer-groups-last))
- (if custom-buffer-sort-alphabetically
- (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
- nil))
- (t
- (not (eq (nth 1 a) 'custom-group) ))))
-
-(defun custom-menu-sort-predicate (a b)
- "Return t iff A should come before B in a customization menu.
-A and B should be members of a `custom-group' property."
- (cond ((and (not custom-menu-groups-first)
- (not custom-menu-sort-alphabetically))
- nil)
- ((or (eq (eq (nth 1 a) 'custom-group) (eq (nth 1 b) 'custom-group))
- (not custom-menu-groups-first))
- (if custom-menu-sort-alphabetically
- (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))
- nil))
- (t
- (eq (nth 1 a) 'custom-group) )))
+(defun custom-sort-items (items sort-alphabetically order-groups)
+ "Return a sorted copy of ITEMS.
+ITEMS should be a `custom-group' property.
+If SORT-ALPHABETICALLY non-nil, sort alphabetically.
+If ORDER-GROUPS is `first' order groups before non-groups, if `last' order
+groups after non-groups, if nil do not order groups at all."
+ (sort (copy-sequence items)
+ (lambda (a b)
+ (let ((typea (nth 1 a)) (typeb (nth 1 b))
+ (namea (symbol-name (nth 0 a))) (nameb (symbol-name (nth 0 b))))
+ (cond ((not order-groups)
+ ;; Since we don't care about A and B order, maybe sort.
+ (when sort-alphabetically
+ (string-lessp namea nameb)))
+ ((eq typea 'custom-group)
+ ;; If B is also a group, maybe sort. Otherwise, order A and B.
+ (if (eq typeb 'custom-group)
+ (when sort-alphabetically
+ (string-lessp namea nameb))
+ (eq order-groups 'first)))
+ ((eq typeb 'custom-group)
+ ;; Since A cannot be a group, order A and B.
+ (eq order-groups 'last))
+ (sort-alphabetically
+ ;; Since A and B cannot be groups, sort.
+ (string-lessp namea nameb)))))))
;;; Custom Mode Commands.
(interactive (list (completing-read "Customize face: (default all) "
obarray 'custom-facep)))
(if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
- (let ((found nil))
- (message "Looking for faces...")
- (mapcar (lambda (symbol)
- (push (list symbol 'custom-face) found))
- (nreverse (mapcar 'intern
- (sort (mapcar 'symbol-name (face-list))
- 'string-lessp))))
-
- (custom-buffer-create found "*Customize Faces*"))
- (if (stringp symbol)
- (setq symbol (intern symbol)))
+ (custom-buffer-create (custom-sort-items
+ (mapcar (lambda (symbol)
+ (list symbol 'custom-face))
+ (face-list))
+ t nil)
+ "*Customize Faces*")
+ (when (stringp symbol)
+ (setq symbol (intern symbol)))
(unless (symbolp symbol)
(error "Should be a symbol %S" symbol))
(custom-buffer-create (list (list symbol 'custom-face))
(and (get symbol 'customized-value)
(boundp symbol)
(push (list symbol 'custom-variable) found))))
- (if found
- (custom-buffer-create found "*Customize Customized*")
- (error "No customized user options"))))
+ (if (not found)
+ (error "No customized user options")
+ (custom-buffer-create (custom-sort-items found t nil)
+ "*Customize Customized*"))))
;;;###autoload
(defun customize-saved ()
(and (get symbol 'saved-value)
(boundp symbol)
(push (list symbol 'custom-variable) found))))
- (if found
- (custom-buffer-create found "*Customize Saved*")
- (error "No saved user options"))))
+ (if (not found )
+ (error "No saved user options")
+ (custom-buffer-create (custom-sort-items found t nil)
+ "*Customize Saved*"))))
;;;###autoload
(defun customize-apropos (regexp &optional all)
(push (list symbol 'custom-variable) found)))))
(if (not found)
(error "No matches")
- (let ((custom-buffer-sort-alphabetically t))
- (custom-buffer-create (sort found 'custom-buffer-sort-predicate)
- "*Customize Apropos*")))))
+ (custom-buffer-create (custom-sort-items found t
+ custom-buffer-order-groups)
+ "*Customize Apropos*"))))
;;;###autoload
(defun customize-apropos-options (regexp &optional arg)
;;; The Tree Browser.
;;;###autoload
-(defun customize-browse ()
+(defun customize-browse (group)
"Create a tree browser for the customize hierarchy."
- (interactive)
+ (interactive (list (let ((completion-ignore-case t))
+ (completing-read "Customize group: (default emacs) "
+ obarray
+ (lambda (symbol)
+ (get symbol 'custom-group))
+ t))))
+
+ (when (stringp group)
+ (if (string-equal "" group)
+ (setq group 'emacs)
+ (setq group (intern group))))
(let ((name "*Customize Browser*"))
(kill-buffer (get-buffer-create name))
(switch-to-buffer (get-buffer-create name)))
(widget-create 'custom-group
:custom-last t
:custom-state 'unknown
- :tag (custom-unlispify-tag-name 'emacs)
- :value 'emacs))
+ :tag (custom-unlispify-tag-name group)
+ :value group))
(goto-char (point-min)))
(define-widget 'custom-tree-visibility 'item
"Control visibility of of items in the customize tree browser."
- :button-prefix "["
- :button-suffix "]"
- :format "%[%t%]"
+ :format "%[[%t]%]"
:action 'custom-tree-visibility-action)
(defun custom-tree-visibility-action (widget &rest ignore)
(define-widget 'custom-tree-group-tag 'push-button
"Show parent in other window when activated."
:tag "Group"
+ :tag-glyph "folder"
:action 'custom-tree-group-tag-action)
(defun custom-tree-group-tag-action (widget &rest ignore)
(define-widget 'custom-tree-variable-tag 'push-button
"Show parent in other window when activated."
:tag "Option"
+ :tag-glyph "option"
:action 'custom-tree-variable-tag-action)
(defun custom-tree-variable-tag-action (widget &rest ignore)
(define-widget 'custom-tree-face-tag 'push-button
"Show parent in other window when activated."
:tag "Face"
+ :tag-glyph "face"
:action 'custom-tree-face-tag-action)
(defun custom-tree-face-tag-action (widget &rest ignore)
(let ((parent (widget-get widget :parent)))
(customize-face-other-window (widget-value parent))))
+(defconst custom-tree-alist '((" " "space")
+ (" | " "vertical")
+ ("-\\ " "top")
+ (" |-" "middle")
+ (" `-" "bottom")))
+
+(defun custom-tree-insert-prefix (prefix)
+ "Insert PREFIX. On XEmacs convert it to line graphics."
+ (if nil ; (string-match "XEmacs" emacs-version)
+ (progn
+ (insert "*")
+ (while (not (string-equal prefix ""))
+ (let ((entry (substring prefix 0 3)))
+ (setq prefix (substring prefix 3))
+ (let ((overlay (make-overlay (1- (point)) (point) nil t nil))
+ (name (nth 1 (assoc entry custom-tree-alist))))
+ (overlay-put overlay 'end-glyph (widget-glyph-find name entry))
+ (overlay-put overlay 'start-open t)
+ (overlay-put overlay 'end-open t)))))
+ (insert prefix)))
+
;;; Modification of Basic Widgets.
;;
;; We add extra properties to the basic widgets needed here. This is
found)
(insert (or initial-string "Parent groups:"))
(mapatoms (lambda (symbol)
- (let ((group (get symbol 'custom-group)))
- (when (assq name group)
- (when (eq type (nth 1 (assq name group)))
- (insert " ")
- (push (widget-create-child-and-convert
- widget 'custom-group-link
- :tag (custom-unlispify-tag-name symbol)
- symbol)
- buttons)
- (setq found t))))))
+ (let ((entry (assq name (get symbol 'custom-group))))
+ (when (eq (nth 1 entry) type)
+ (insert " ")
+ (push (widget-create-child-and-convert
+ widget 'custom-group-link
+ :tag (custom-unlispify-tag-name symbol)
+ symbol)
+ buttons)
+ (setq found t)))))
(widget-put widget :buttons buttons)
(if found
(insert "\n")
(setq form 'lisp)))
;; Now we can create the child widget.
(cond ((eq custom-buffer-style 'tree)
- (insert prefix (if last " +--- " " |--- "))
+ (insert prefix (if last " `--- " " |--- "))
(push (widget-create-child-and-convert
widget 'custom-tree-variable-tag)
buttons)
(unless tag
(setq tag (prin1-to-string symbol)))
(cond ((eq custom-buffer-style 'tree)
- (insert prefix (if is-last " +--- " " |--- "))
+ (insert prefix (if is-last " `--- " " |--- "))
(push (widget-create-child-and-convert
widget 'custom-tree-face-tag)
buttons)
(symbol (widget-value widget)))
(cond ((and (eq custom-buffer-style 'tree)
(eq state 'hidden))
- (insert prefix)
+ (custom-tree-insert-prefix prefix)
(push (widget-create-child-and-convert
- widget 'custom-tree-visibility :tag "+")
+ widget 'custom-tree-visibility
+ ;; :tag-glyph "plus"
+ :tag "+")
buttons)
(insert "-- ")
+ ;; (widget-glyph-insert nil "-- " "horizontal")
(push (widget-create-child-and-convert
widget 'custom-tree-group-tag)
buttons)
(widget-put widget :buttons buttons))
((and (eq custom-buffer-style 'tree)
(zerop (length (get symbol 'custom-group))))
- (insert prefix "[ ]-- ")
+ (custom-tree-insert-prefix prefix)
+ (insert "[ ]-- ")
+ ;; (widget-glyph-insert nil "[ ]" "empty")
+ ;; (widget-glyph-insert nil "-- " "horizontal")
(push (widget-create-child-and-convert
widget 'custom-tree-group-tag)
buttons)
(insert " " tag "\n")
(widget-put widget :buttons buttons))
((eq custom-buffer-style 'tree)
- (insert prefix)
+ (custom-tree-insert-prefix prefix)
(custom-load-widget widget)
(if (zerop (length (get symbol 'custom-group)))
(progn
- (insert prefix "[ ]-- ")
+ (custom-tree-insert-prefix prefix)
+ (insert "[ ]-- ")
+ ;; (widget-glyph-insert nil "[ ]" "empty")
+ ;; (widget-glyph-insert nil "-- " "horizontal")
(push (widget-create-child-and-convert
widget 'custom-tree-group-tag)
buttons)
(insert " " tag "\n")
(widget-put widget :buttons buttons))
(push (widget-create-child-and-convert
- widget 'custom-tree-visibility :tag "-")
+ widget 'custom-tree-visibility
+ ;; :tag-glyph "minus"
+ :tag "-")
buttons)
- (insert "-+ ")
+ (insert "-\\ ")
+ ;; (widget-glyph-insert nil "-\\ " "top")
(push (widget-create-child-and-convert
widget 'custom-tree-group-tag)
buttons)
(insert " " tag "\n")
(widget-put widget :buttons buttons)
(message "Creating group...")
- (let* ((members (copy-sequence (get symbol 'custom-group)))
+ (let* ((members (custom-sort-items (get symbol 'custom-group)
+ custom-browse-sort-alphabetically
+ custom-browse-order-groups))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
(length (length members))
;; Members.
(message "Creating group...")
(custom-load-widget widget)
- (let* ((members (sort (copy-sequence (get symbol 'custom-group))
- 'custom-buffer-sort-predicate))
+ (let* ((members (custom-sort-items (get symbol 'custom-group)
+ custom-buffer-sort-alphabetically
+ custom-buffer-order-groups))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
(length (length members))
(defconst custom-help-menu
'("Customize"
["Update menu..." Custom-menu-update t]
+ ["Browse..." (customize-browse 'emacs) t]
["Group..." customize-group t]
["Variable..." customize-variable t]
["Face..." customize-face t]
(< (length (get symbol 'custom-group)) widget-menu-max-size))
(let ((custom-prefix-list (custom-prefix-add symbol
custom-prefix-list))
- (members (sort (copy-sequence (get symbol 'custom-group))
- 'custom-menu-sort-predicate)))
+ (members (custom-sort-items (get symbol 'custom-group)
+ custom-menu-sort-alphabetically
+ custom-menu-order-groups)))
(custom-load-symbol symbol)
`(,(custom-unlispify-menu-entry symbol t)
,item
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.9929
+;; Version: 1.9936
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
:type 'boolean
:group 'widgets)
+(defcustom widget-field-use-before-change
+ (or (> emacs-minor-version 34)
+ (> emacs-major-version 20)
+ (string-match "XEmacs" emacs-version))
+ "Non-nil means use `before-change-functions' to track editable fields.
+This enables the use of undo, but doesn'f work on Emacs 19.34 and earlier.
+Using before hooks also means that the :notify function can't know the
+new value."
+ :type 'boolean
+ :group 'widgets)
+
(defun widget-specify-field (widget from to)
"Specify editable button for WIDGET between FROM and TO."
(put-text-property from to 'read-only nil)
"In WIDGET, insert GLYPH.
If optional arguments DOWN and INACTIVE are given, they should be
glyphs used when the widget is pushed and inactive, respectively."
- (set-glyph-property glyph 'widget widget)
- (when down
- (set-glyph-property down 'widget widget))
- (when inactive
- (set-glyph-property inactive 'widget widget))
+ (when widget
+ (set-glyph-property glyph 'widget widget)
+ (when down
+ (set-glyph-property down 'widget widget))
+ (when inactive
+ (set-glyph-property inactive 'widget widget)))
(insert "*")
(let ((ext (make-extent (point) (1- (point))))
- (help-echo (widget-get widget :help-echo)))
+ (help-echo (and widget (widget-get widget :help-echo))))
(set-extent-property ext 'invisible t)
(set-extent-property ext 'start-open t)
(set-extent-property ext 'end-open t)
(when help-echo
(set-extent-property ext 'balloon-help help-echo)
(set-extent-property ext 'help-echo help-echo)))
- (widget-put widget :glyph-up glyph)
- (when down (widget-put widget :glyph-down down))
- (when inactive (widget-put widget :glyph-inactive inactive)))
+ (when widget
+ (widget-put widget :glyph-up glyph)
+ (when down (widget-put widget :glyph-down down))
+ (when inactive (widget-put widget :glyph-inactive inactive))))
;;; Buttons.
(widget-apply-action button event)))
(overlay-put overlay 'face face)
(overlay-put overlay 'mouse-face mouse-face)))
- (let (command up)
+ (let ((up t)
+ command)
;; Find the global command to run, and check whether it
;; is bound to an up event.
(cond ((setq command ;down event
- (lookup-key widget-global-map [ button2 ])))
+ (lookup-key widget-global-map [ button2 ]))
+ (setq up nil))
((setq command ;down event
- (lookup-key widget-global-map [ down-mouse-2 ])))
+ (lookup-key widget-global-map [ down-mouse-2 ]))
+ (setq up nil))
((setq command ;up event
- (lookup-key widget-global-map [ button2up ]))
- (setq up t))
+ (lookup-key widget-global-map [ button2up ])))
((setq command ;up event
- (lookup-key widget-global-map [ mouse-2]))
- (setq up t)))
- (when command
+ (lookup-key widget-global-map [ mouse-2]))))
+ (when up
;; Don't execute up events twice.
- (when up
- (while (not (button-release-event-p event))
- (setq event (widget-read-event))))
+ (while (not (button-release-event-p event))
+ (setq event (widget-read-event))))
+ (when command
(call-interactively command))))))
(t
(message "You clicked somewhere weird."))))
(widget-clear-undo)
;; We need to maintain text properties and size of the editing fields.
(make-local-variable 'after-change-functions)
- (make-local-variable 'before-change-functions)
(setq after-change-functions
(if widget-field-list '(widget-after-change) nil))
- (setq before-change-functions
- (if widget-field-list '(widget-before-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))))
(defvar widget-field-last nil)
;; Last field containing point.
;; Insert text representing the `on' and `off' states.
(let* ((tag (or (widget-get widget :tag)
(widget-get widget :value)))
+ (tag-glyph (widget-get widget :tag-glyph))
(text (concat widget-push-button-prefix
tag widget-push-button-suffix))
(gui (cdr (assoc tag widget-push-button-cache))))
- (if (and (fboundp 'make-gui-button)
+ (cond (tag-glyph
+ (widget-glyph-insert widget text tag-glyph))
+ ((and (fboundp 'make-gui-button)
(fboundp 'make-glyph)
widget-push-button-gui
(fboundp 'device-on-window-system-p)
(device-on-window-system-p)
(string-match "XEmacs" emacs-version))
- (progn
- (unless gui
- (setq gui (make-gui-button tag 'widget-gui-action widget))
- (push (cons tag gui) widget-push-button-cache))
- (widget-glyph-insert-glyph widget
- (make-glyph
- (list (nth 0 (aref gui 1))
- (vector 'string ':data text)))
- (make-glyph
- (list (nth 1 (aref gui 1))
- (vector 'string ':data text)))
- (make-glyph
- (list (nth 2 (aref gui 1))
- (vector 'string ':data text)))))
- (insert text))))
+ (unless gui
+ (setq gui (make-gui-button tag 'widget-gui-action widget))
+ (push (cons tag gui) widget-push-button-cache))
+ (widget-glyph-insert-glyph widget
+ (make-glyph
+ (list (nth 0 (aref gui 1))
+ (vector 'string ':data text)))
+ (make-glyph
+ (list (nth 1 (aref gui 1))
+ (vector 'string ':data text)))
+ (make-glyph
+ (list (nth 2 (aref gui 1))
+ (vector 'string ':data text)))))
+ (t
+ (insert text)))))
(defun widget-gui-action (widget)
"Apply :action for WIDGET."
projects / emacs.git / commitdiff