;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.9908
+;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
:group 'customize
:group 'faces)
+(defgroup custom-buffer nil
+ "Control the customize buffers."
+ :prefix "custom-"
+ :group 'customize)
+
+(defgroup custom-menu nil
+ "Control how the customize menus."
+ :prefix "custom-"
+ :group 'customize)
+
(defgroup abbrev-mode nil
"Word abbreviations mode."
:group 'abbrev)
(defcustom custom-unlispify-menu-entries t
"Display menu entries as words instead of symbols if non nil."
- :group 'customize
+ :group 'custom-menu
:type 'boolean)
(defun custom-unlispify-menu-entry (symbol &optional no-suffix)
(defcustom custom-unlispify-tag-names t
"Display tag names as words instead of symbols if non nil."
- :group 'customize
+ :group 'custom-buffer
:type 'boolean)
(defun custom-unlispify-tag-name (symbol)
;;; Sorting.
-(defcustom custom-buffer-sort-predicate 'custom-buffer-sort-alphabetically
+(defcustom custom-buffer-sort-predicate 'ignore
"Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (function-item custom-buffer-sort-alphabetically)
+ :type '(radio (const :tag "Unsorted" ignore)
+ (const :tag "Alphabetic" custom-sort-items-alphabetically)
(function :tag "Other"))
- :group 'customize)
+ :group 'custom-buffer)
-(defun custom-buffer-sort-alphabetically (a b)
- "Return t iff is A should be before B.
-A and B should be members of a `custom-group' property.
-The members are sorted alphabetically, except that all groups are
-sorted after all non-groups."
- (cond ((and (eq (nth 1 a) 'custom-group)
- (not (eq (nth 1 b) 'custom-group)))
- nil)
- ((and (eq (nth 1 b) 'custom-group)
- (not (eq (nth 1 a) 'custom-group)))
- t)
- (t
- (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))))
+(defcustom custom-buffer-order-predicate 'custom-sort-groups-last
+ "Function used for sorting group members in buffers.
+The value should be useful as a predicate for `sort'.
+The list to be sorted is the value of the groups `custom-group' property."
+ :type '(radio (const :tag "Groups first" custom-sort-groups-first)
+ (const :tag "Groups last" custom-sort-groups-last)
+ (function :tag "Other"))
+ :group 'custom-buffer)
-(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically
+(defcustom custom-menu-sort-predicate 'ignore
"Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
- :type '(radio (function-item custom-menu-sort-alphabetically)
+ :type '(radio (const :tag "Unsorted" ignore)
+ (const :tag "Alphabetic" custom-sort-items-alphabetically)
(function :tag "Other"))
- :group 'customize)
+ :group 'custom-menu)
-(defun custom-menu-sort-alphabetically (a b)
- "Return t iff is A should be before B.
-A and B should be members of a `custom-group' property.
-The members are sorted alphabetically, except that all groups are
-sorted before all non-groups."
- (cond ((and (eq (nth 1 a) 'custom-group)
- (not (eq (nth 1 b) 'custom-group)))
- t)
- ((and (eq (nth 1 b) 'custom-group)
- (not (eq (nth 1 a) 'custom-group)))
- nil)
- (t
- (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))))
+(defcustom custom-menu-order-predicate 'custom-sort-groups-first
+ "Function used for sorting group members in menus.
+The value should be useful as a predicate for `sort'.
+The list to be sorted is the value of the groups `custom-group' property."
+ :type '(radio (const :tag "Groups first" custom-sort-groups-first)
+ (const :tag "Groups last" custom-sort-groups-last)
+ (function :tag "Other"))
+ :group 'custom-menu)
+
+(defun custom-sort-items-alphabetically (a b)
+ "Return t iff A is alphabetically before B and the same custom type.
+A and B should be members of a `custom-group' property."
+ (and (eq (nth 1 a) (nth 1 b))
+ (string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))))
+
+(defun custom-sort-groups-first (a b)
+ "Return t iff A a custom group and B is a not.
+A and B should be members of a `custom-group' property."
+ (and (eq (nth 1 a) 'custom-group)
+ (not (eq (nth 1 b) 'custom-group))))
+
+(defun custom-sort-groups-last (a b)
+ "Return t iff B a custom group and A is a not.
+A and B should be members of a `custom-group' property."
+ (and (eq (nth 1 b) 'custom-group)
+ (not (eq (nth 1 a) 'custom-group))))
;;; Custom Mode Commands.
"If non-nil, only show a single reset button in customize buffers.
This button will have a menu with all three reset operations."
:type 'boolean
- :group 'customize)
+ :group 'custom-buffer)
(defun custom-buffer-create-internal (options)
(message "Creating customization buffer...")
;;; The `custom-magic' Widget.
+(defgroup custom-magic-faces nil
+ "Faces used by the magic button."
+ :group 'custom-faces
+ :group 'custom-buffer)
+
(defface custom-invalid-face '((((class color))
(:foreground "yellow" :background "red"))
(t
(:bold t :italic t :underline t)))
- "Face used when the customize item is invalid.")
+ "Face used when the customize item is invalid."
+ :group 'custom-magic-faces)
(defface custom-rogue-face '((((class color))
(:foreground "pink" :background "black"))
(t
(:underline t)))
- "Face used when the customize item is not defined for customization.")
+ "Face used when the customize item is not defined for customization."
+ :group 'custom-magic-faces)
(defface custom-modified-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t :bold)))
- "Face used when the customize item has been modified.")
+ "Face used when the customize item has been modified."
+ :group 'custom-magic-faces)
(defface custom-set-face '((((class color))
(:foreground "blue" :background "white"))
(t
(:italic t)))
- "Face used when the customize item has been set.")
+ "Face used when the customize item has been set."
+ :group 'custom-magic-faces)
(defface custom-changed-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t)))
- "Face used when the customize item has been changed.")
+ "Face used when the customize item has been changed."
+ :group 'custom-magic-faces)
(defface custom-saved-face '((t (:underline t)))
- "Face used when the customize item has been saved.")
+ "Face used when the customize item has been saved."
+ :group 'custom-magic-faces)
(defconst custom-magic-alist '((nil "#" underline "\
uninitialized, you should not see this.")
:type '(choice (const :tag "no" nil)
(const short)
(const long))
- :group 'customize)
+ :group 'custom-buffer)
(defcustom custom-magic-show-hidden '(option face)
"Control whether the state button is shown for hidden items.
button should be visible. Possible categories are `group', `option',
and `face'."
:type '(set (const group) (const option) (const face))
- :group 'customize)
+ :group 'custom-buffer)
(defcustom custom-magic-show-button nil
"Show a magic button indicating the state of each customization option."
:type 'boolean
- :group 'customize)
+ :group 'custom-buffer)
(define-widget 'custom-magic 'default
"Show and manipulate state for a customization option."
(custom-load-widget widget)
(let* ((level (widget-get widget :custom-level))
(symbol (widget-value widget))
- (members (sort (get symbol 'custom-group)
- custom-buffer-sort-predicate))
+ (members (sort (sort (copy-sequence (get symbol 'custom-group))
+ custom-buffer-sort-predicate)
+ custom-buffer-order-predicate))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
(length (length members))
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))))
members)))
- (put symbol 'custom-group members)
(message "Creating group magic...")
(mapcar 'custom-magic-reset children)
(message "Creating group state...")
(defcustom custom-menu-nesting 2
"Maximum nesting in custom menus."
:type 'integer
- :group 'customize)
+ :group 'custom-menu)
(defun custom-face-menu-create (widget symbol)
"Ignoring WIDGET, create a menu entry for customization face SYMBOL."
(< (length (get symbol 'custom-group)) widget-menu-max-size))
(let ((custom-prefix-list (custom-prefix-add symbol
custom-prefix-list))
- (members (sort (get symbol 'custom-group)
- custom-menu-sort-predicate)))
- (put symbol 'custom-group members)
+ (members (sort (sort (copy-sequence (get symbol 'custom-group))
+ custom-menu-sort-predicate)
+ custom-menu-order-predicate)))
(custom-load-symbol symbol)
`(,(custom-unlispify-menu-entry symbol t)
,item
(defcustom custom-mode-hook nil
"Hook called when entering custom-mode."
:type 'hook
- :group 'customize)
+ :group 'custom-buffer )
(defun custom-mode ()
"Major mode for editing customization buffers.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.9905
+;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
(interactive "P")
(cond ((null arg)
(setq widget-minor-mode (not widget-minor-mode)))
- ((<= 0 arg)
+ ((<= arg 0)
(setq widget-minor-mode nil))
(t
(setq widget-minor-mode t)))
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.9908
+;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
"http://www.dina.kvl.dk/~abraham/custom/")
:prefix "widget-"
:group 'extensions
- :group 'faces
:group 'hypermedia)
+(defgroup widget-faces nil
+ "Faces used by the widget library."
+ :group 'widgets
+ :group 'faces)
+
(defface widget-button-face '((t (:bold t)))
"Face used for widget buttons."
- :group 'widgets)
+ :group 'widget-faces)
(defcustom widget-mouse-face 'highlight
"Face used for widget buttons when the mouse is above them."
:type 'face
- :group 'widgets)
+ :group 'widget-faces)
(defface widget-field-face '((((class grayscale color)
(background light))
(t
(:italic t)))
"Face used for editable fields."
- :group 'widgets)
+ :group 'widget-faces)
;;; Utility functions.
;;
(t
(:italic t)))
"Face used for inactive widgets."
- :group 'widgets)
+ :group 'widget-faces)
(defun widget-specify-inactive (widget from to)
"Make WIDGET inactive for user modifications."
(unless (widget-get widget :inactive)
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face 'widget-inactive-face)
- (overlay-put overlay 'mouse-face 'widget-inactive-face)
+ ;; This is disabled, as it makes the mouse cursor change shape.
+ ;; (overlay-put overlay 'mouse-face 'widget-inactive-face)
(overlay-put overlay 'evaporate t)
(overlay-put overlay 'priority 100)
(overlay-put overlay (if (string-match "XEmacs" emacs-version)
(throw 'child child)))
nil)))
+(defun widget-map-buttons (function &optional buffer maparg)
+ "Map FUNCTION over the buttons in BUFFER.
+FUNCTION is called with the arguments WIDGET and MAPARG.
+
+If FUNCTION returns non-nil, the walk is cancelled.
+
+The arguments MAPARG, and BUFFER default to nil and (current-buffer),
+respectively."
+ (let ((cur (point-min))
+ (widget nil)
+ (parent nil)
+ (overlays (if buffer
+ (save-excursion (set-buffer buffer) (overlay-lists))
+ (overlay-lists))))
+ (setq overlays (append (car overlays) (cdr overlays)))
+ (while (setq cur (pop overlays))
+ (setq widget (overlay-get cur 'button))
+ (if (and widget (funcall function widget maparg))
+ (setq overlays nil)))))
+
;;; Glyphs.
(defcustom widget-glyph-directory (concat data-directory "custom/")
(apply 'insert args)
(widget-specify-text from (point))))
+(defun widget-convert-text (type from to &optional button-from button-to)
+ "Return a widget of type TYPE with endpoint FROM TO.
+No text will be inserted to the buffer, instead the text between FROM
+and TO will be used as the widgets end points. If optional arguments
+BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
+button end points."
+ (let ((widget (widget-convert type))
+ (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)
+ (widget-put widget :to to)
+ (when button-from
+ (widget-specify-button widget button-from button-to))
+ widget))
+
+(defun widget-convert-button (type from to)
+ "Return a widget of type TYPE with endpoint FROM TO.
+No text will be inserted to the buffer, instead the text between FROM
+and TO will be used as the widgets end points, as well as the widgets
+button end points."
+ (widget-convert-text type from to from to))
+
;;; Keymap and Commands.
(defvar widget-keymap nil
(t
(:bold t :underline t)))
"Face used for pressed buttons."
- :group 'widgets)
+ :group 'widget-faces)
(defun widget-button-click (event)
"Invoke button below mouse pointer."
widget-field-list (cons field widget-field-list))
(let ((from (car (widget-get field :field-overlay)))
(to (cdr (widget-get field :field-overlay))))
- (widget-specify-field field from to)
+ (widget-specify-field field
+ (marker-position from) (marker-position to))
(set-marker from nil)
(set-marker to nil))))
(widget-clear-undo)
(defun widget-field-buffer (widget)
"Return the start of WIDGET's editing field."
- (overlay-buffer (widget-get widget :field-overlay)))
+ (let ((overlay (widget-get widget :field-overlay)))
+ (and overlay (overlay-buffer overlay))))
(defun widget-field-start (widget)
"Return the start of WIDGET's editing field."
- (overlay-start (widget-get widget :field-overlay)))
+ (let ((overlay (widget-get widget :field-overlay)))
+ (and overlay (overlay-start overlay))))
(defun widget-field-end (widget)
"Return the end of WIDGET's editing field."
- ;; Don't subtract one if local-map works at the end of the overlay.
- (1- (overlay-end (widget-get widget :field-overlay))))
+ (let ((overlay (widget-get widget :field-overlay)))
+ ;; Don't subtract one if local-map works at the end of the overlay.
+ (and overlay (1- (overlay-end overlay)))))
(defun widget-field-find (pos)
"Return the field at POS.
(defun widget-default-format-handler (widget escape)
;; We recognize the %h escape by default.
- (let* ((buttons (widget-get widget :buttons))
- (doc-property (widget-get widget :documentation-property))
- (doc-try (cond ((widget-get widget :doc))
- ((symbolp doc-property)
- (documentation-property (widget-get widget :value)
- doc-property))
- (t
- (funcall doc-property (widget-get widget :value)))))
- (doc-text (and (stringp doc-try)
- (> (length doc-try) 1)
- doc-try)))
+ (let* ((buttons (widget-get widget :buttons)))
(cond ((eq escape ?h)
- (when doc-text
- (and (eq (preceding-char) ?\n)
- (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- ;; The `*' in the beginning is redundant.
- (when (eq (aref doc-text 0) ?*)
- (setq doc-text (substring doc-text 1)))
- ;; Get rid of trailing newlines.
- (when (string-match "\n+\\'" doc-text)
- (setq doc-text (substring doc-text 0 (match-beginning 0))))
- (push (widget-create-child-and-convert
- widget 'documentation-string
- doc-text)
- buttons)))
+ (let* ((doc-property (widget-get widget :documentation-property))
+ (doc-try (cond ((widget-get widget :doc))
+ ((symbolp doc-property)
+ (documentation-property
+ (widget-get widget :value)
+ doc-property))
+ (t
+ (funcall doc-property
+ (widget-get widget :value)))))
+ (doc-text (and (stringp doc-try)
+ (> (length doc-try) 1)
+ doc-try)))
+ (when doc-text
+ (and (eq (preceding-char) ?\n)
+ (widget-get widget :indent)
+ (insert-char ? (widget-get widget :indent)))
+ ;; The `*' in the beginning is redundant.
+ (when (eq (aref doc-text 0) ?*)
+ (setq doc-text (substring doc-text 1)))
+ ;; Get rid of trailing newlines.
+ (when (string-match "\n+\\'" doc-text)
+ (setq doc-text (substring doc-text 0 (match-beginning 0))))
+ (push (widget-create-child-and-convert
+ widget 'documentation-string
+ doc-text)
+ buttons))))
(t
(error "Unknown escape `%c'" escape)))
(widget-put widget :buttons buttons)))
(:foreground "dark green"))
(t nil))
"Face used for documentation text."
- :group 'widgets)
+ :group 'widget-faces)
(define-widget 'documentation-string 'item
"A documentation string."
(defun widget-documentation-string-value-create (widget)
;; Insert documentation string.
(let ((doc (widget-value widget))
- (shown (widget-get (widget-get widget :parent) :documentation-shown)))
+ (shown (widget-get (widget-get widget :parent) :documentation-shown))
+ (start (point)))
(if (string-match "\n" doc)
(let ((before (substring doc 0 (match-beginning 0)))
(after (substring doc (match-beginning 0)))
- (start (point))
buttons)
(insert before " ")
(widget-specify-doc widget start (point))
(insert after)
(widget-specify-doc widget start (point)))
(widget-put widget :buttons buttons))
- (insert doc)))
+ (insert doc)
+ (widget-specify-doc widget start (point))))
(insert "\n"))
(defun widget-documentation-string-action (widget &rest ignore)
:prompt-history 'widget-variable-prompt-value-history
:tag "Variable")
+(when (featurep 'mule)
+ (defvar widget-coding-system-prompt-value-history nil
+ "History of input to `widget-coding-system-prompt-value'.")
+
+ (define-widget 'coding-system 'symbol
+ "A MULE coding-system."
+ :format "%{%t%}: %v"
+ :tag "Coding system"
+ :prompt-history 'widget-coding-system-prompt-value-history
+ :prompt-value 'widget-coding-system-prompt-value
+ :action 'widget-coding-system-action)
+
+ (defun widget-coding-system-prompt-value (widget prompt value unbound)
+ ;; Read coding-system from minibuffer.
+ (intern
+ (completing-read (format "%s (default %s) " prompt value)
+ (mapcar (function
+ (lambda (sym)
+ (list (symbol-name sym))
+ ))
+ (coding-system-list)))))
+
+ (defun widget-coding-system-action (widget &optional event)
+ ;; Read a file name from the minibuffer.
+ (let ((answer
+ (widget-coding-system-prompt-value
+ widget
+ (widget-apply widget :menu-tag-get)
+ (widget-value widget)
+ t)))
+ (widget-value-set widget answer)
+ (widget-apply widget :notify widget event)
+ (widget-setup)))
+ )
+
(define-widget 'sexp 'editable-field
"An arbitrary lisp expression."
:tag "Lisp expression"
projects / emacs.git / commitdiff