;;; widget-edit.el --- Functions for creating and using widgets.
;;
-;; Copyright (C) 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 0.995
+;; Version: 1.38
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
(autoload 'pp-to-string "pp")
(autoload 'Info-goto-node "info")
+(if (string-match "XEmacs" emacs-version)
+ ;; XEmacs spell `intangible' as `atomic'.
+ (defun widget-make-intangible (from to side)
+ "Make text between FROM and TO atomic with regard to movement.
+Third argument should be `start-open' if it should be sticky to the rear,
+and `end-open' if it should sticky to the front."
+ (require 'atomic-extents)
+ (let ((ext (make-extent from to)))
+ ;; XEmacs doesn't understant different kinds of read-only, so
+ ;; we have to use extents instead.
+ (put-text-property from to 'read-only nil)
+ (set-extent-property ext 'read-only t)
+ (set-extent-property ext 'start-open nil)
+ (set-extent-property ext 'end-open nil)
+ (set-extent-property ext side t)
+ (set-extent-property ext 'atomic t)))
+ (defun widget-make-intangible (from to size)
+ "Make text between FROM and TO intangible."
+ (put-text-property from to 'intangible 'front)))
+
;; The following should go away when bundled with Emacs.
-(condition-case ()
- (require 'custom)
- (error nil))
-
-(unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
- ;; We have the old custom-library, hack around it!
- (defmacro defgroup (&rest args) nil)
- (defmacro defcustom (&rest args) nil)
- (defmacro defface (&rest args) nil)
- (when (fboundp 'copy-face)
- (copy-face 'default 'widget-documentation-face)
- (copy-face 'bold 'widget-button-face)
- (copy-face 'italic 'widget-field-face))
- (defvar widget-mouse-face 'highlight)
- (defvar widget-menu-max-size 40))
+(eval-and-compile
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+
+ (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args) nil)
+ (defmacro defcustom (&rest args) nil)
+ (defmacro defface (&rest args) nil)
+ (define-widget-keywords :prefix :tag :load :link :options :type :group)
+ (when (fboundp 'copy-face)
+ (copy-face 'default 'widget-documentation-face)
+ (copy-face 'bold 'widget-button-face)
+ (copy-face 'italic 'widget-field-face))
+ (defvar widget-mouse-face 'highlight)
+ (defvar widget-menu-max-size 40)))
;;; Compatibility.
-(or (fboundp 'event-point)
- ;; XEmacs function missing in Emacs.
- (defun event-point (event)
- "Return the character position of the given mouse-motion, button-press,
+(unless (fboundp 'event-point)
+ ;; XEmacs function missing in Emacs.
+ (defun event-point (event)
+ "Return the character position of the given mouse-motion, button-press,
or button-release event. If the event did not occur over a window, or did
not occur over text, then this returns nil. Otherwise, it returns an index
into the buffer visible in the event's window."
- (posn-point (event-start event))))
+ (posn-point (event-start event))))
+
+(unless (fboundp 'error-message-string)
+ ;; Emacs function missing in XEmacs.
+ (defun error-message-string (obj)
+ "Convert an error value to an error message."
+ (let ((buf (get-buffer-create " *error-message*")))
+ (erase-buffer buf)
+ (display-error obj buf)
+ (buffer-string buf))))
;;; Customization.
(defgroup widgets nil
"Customization support for the Widget Library."
+ :link '(custom-manual "(widget)Top")
+ :link '(url-link :tag "Development Page"
+ "http://www.dina.kvl.dk/~abraham/custom/")
+ :prefix "widget-"
:group 'emacs)
-(defface widget-documentation-face '((t ()))
+(defface widget-documentation-face '((((class color)
+ (background dark))
+ (:foreground "lime green"))
+ (((class color)
+ (background light))
+ (:foreground "dark green"))
+ (t nil))
"Face used for documentation text."
:group 'widgets)
:type 'face
:group 'widgets)
-(defface widget-field-face '((((type x)
- (class grayscale color)
+(defface widget-field-face '((((class grayscale color)
(background light))
(:background "light gray"))
- (((type x)
- (class grayscale color)
+ (((class grayscale color)
(background dark))
(:background "dark gray"))
(t
(defcustom widget-menu-max-size 40
"Largest number of items allowed in a popup-menu.
Larger menus are read through the minibuffer."
+ :group 'widgets
:type 'integer)
;;; Utility functions.
;;
;; These are not really widget specific.
-(defun widget-plist-member (plist prop)
+(defsubst widget-plist-member (plist prop)
;; Return non-nil if PLIST has the property PROP.
;; PLIST is a property list, which is a list of the form
;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol.
items nil t)
items)))))
+(defun widget-get-sibling (widget)
+ "Get the item WIDGET is assumed to toggle.
+This is only meaningful for radio buttons or checkboxes in a list."
+ (let* ((parent (widget-get widget :parent))
+ (children (widget-get parent :children))
+ child)
+ (catch 'child
+ (while children
+ (setq child (car children)
+ children (cdr children))
+ (when (eq (widget-get child :button) widget)
+ (throw 'child child)))
+ nil)))
+
;;; Widget text specifications.
;;
;; These functions are for specifying text properties.
;; Default properties.
(add-text-properties from to (list 'read-only t
'front-sticky t
+ 'start-open t
+ 'end-open t
'rear-nonsticky nil)))
(defun widget-specify-field (widget from to)
;; before the field can be modified (e.g. if it belongs to a
;; choice widget). We try to compensate by checking the format
;; string, and hope the user hasn't changed the :create method.
- (put-text-property (- from 2) from 'intangible 'front))
+ (widget-make-intangible (- from 2) from 'end-open))
;; Make it possible to edit back end of the field.
(add-text-properties to (1+ to) (list 'front-sticky nil
+ 'read-only t
'start-open t))
- (when (widget-get widget :size)
- (put-text-property to (1+ to) 'invisible t)
- (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
- (widget-get widget :hide-rear-space))
- ;; WARNING: This is going to lose horrible if the character just
- ;; after the field can be modified (e.g. if it belongs to a
- ;; choice widget). We try to compensate by checking the format
- ;; string, and hope the user hasn't changed the :create method.
- (put-text-property to (+ to 2) 'intangible 'rear))))
+ (cond ((widget-get widget :size)
+ (put-text-property to (1+ to) 'invisible t)
+ (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
+ (widget-get widget :hide-rear-space))
+ ;; WARNING: This is going to lose horrible if the character just
+ ;; after the field can be modified (e.g. if it belongs to a
+ ;; choice widget). We try to compensate by checking the format
+ ;; string, and hope the user hasn't changed the :create method.
+ (widget-make-intangible to (+ to 2) 'start-open)))
+ ((string-match "XEmacs" emacs-version)
+ ;; XEmacs does not allow you to insert before a read-only
+ ;; character, even if it is start.open.
+ ;; XEmacs does allow you to delete an read-only extent, so
+ ;; making the terminating newline read only doesn't help.
+ ;; I tried putting an invisible intangible read-only space
+ ;; before the newline, which gave really weird effects.
+ ;; So for now, we just have trust the user not to delete the
+ ;; newline.
+ (put-text-property to (1+ to) 'read-only nil))))
(defun widget-specify-field-update (widget from to)
;; Specify editable button for WIDGET between FROM and TO.
(let ((map (widget-get widget :keymap))
+ (secret (widget-get widget :secret))
+ (secret-to to)
+ (size (widget-get widget :size))
(face (or (widget-get widget :value-face)
'widget-field-face)))
+
+ (when secret
+ (while (and size
+ (not (zerop size))
+ (> secret-to from)
+ (eq (char-after (1- secret-to)) ?\ ))
+ (setq secret-to (1- secret-to)))
+
+ (save-excursion
+ (goto-char from)
+ (while (< (point) secret-to)
+ (let ((old (get-text-property (point) 'secret)))
+ (when old
+ (subst-char-in-region (point) (1+ (point)) secret old)))
+ (forward-char))))
+
(set-text-properties from to (list 'field widget
'read-only nil
'keymap map
'local-map map
'face face))
+
+ (when secret
+ (save-excursion
+ (goto-char from)
+ (while (< (point) secret-to)
+ (let ((old (following-char)))
+ (subst-char-in-region (point) (1+ (point)) old secret)
+ (put-text-property (point) (1+ (point)) 'secret old))
+ (forward-char))))
+
(unless (widget-get widget :size)
- (put-text-property to (1+ to) 'face face))))
+ (add-text-properties to (1+ to) (list 'field widget
+ 'face face)))
+ (add-text-properties to (1+ to) (list 'local-map map
+ 'keymap map))))
(defun widget-specify-button (widget from to)
;; Specify button for WIDGET between FROM and TO.
'end-open t
'face face))))
+(defun widget-specify-sample (widget from to)
+ ;; Specify sample for WIDGET between FROM and TO.
+ (let ((face (widget-apply widget :sample-face-get)))
+ (when face
+ (add-text-properties from to (list 'start-open t
+ 'end-open t
+ 'face face)))))
+
(defun widget-specify-doc (widget from to)
;; Specify documentation for WIDGET between FROM and TO.
(add-text-properties from to (list 'widget-doc widget
;;; Widget Properties.
+(defsubst widget-type (widget)
+ "Return the type of WIDGET, a symbol."
+ (car widget))
+
(defun widget-put (widget property value)
"In WIDGET set PROPERTY to VALUE.
The value can later be retrived with `widget-get'."
"In WIDGET, get the value of PROPERTY.
The value could either be specified when the widget was created, or
later with `widget-put'."
- (cond ((widget-plist-member (cdr widget) property)
- (plist-get (cdr widget) property))
- ((car widget)
- (widget-get (get (car widget) 'widget-type) property))
- (t nil)))
+ (let ((missing t)
+ value tmp)
+ (while missing
+ (cond ((setq tmp (widget-plist-member (cdr widget) property))
+ (setq value (car (cdr tmp))
+ missing nil))
+ ((setq tmp (car widget))
+ (setq widget (get tmp 'widget-type)))
+ (t
+ (setq missing nil))))
+ value))
(defun widget-member (widget property)
"Non-nil iff there is a definition in WIDGET for PROPERTY."
(cons (list (car vals)) (cdr vals)))
(t nil)))
+;;; Glyphs.
+
+(defcustom widget-glyph-directory (concat data-directory "custom/")
+ "Where widget glyphs are located.
+If this variable is nil, widget will try to locate the directory
+automatically. This does not work yet."
+ :group 'widgets
+ :type 'directory)
+
+(defcustom widget-glyph-enable t
+ "If non nil, use glyphs in images when available."
+ :group 'widgets
+ :type 'boolean)
+
+(defun widget-glyph-insert (widget tag image)
+ "In WIDGET, insert the text TAG or, if supported, IMAGE.
+IMAGE should be a name sans extension of an xpm or xbm file located in
+`widget-glyph-directory'"
+ (if (and (string-match "XEmacs" emacs-version)
+ widget-glyph-enable
+ (fboundp 'make-glyph)
+ image)
+ (let ((file (concat widget-glyph-directory
+ (if (string-match "/\\'" widget-glyph-directory)
+ ""
+ "/")
+ image
+ (if (featurep 'xpm) ".xpm" ".xbm"))))
+ (if (file-readable-p file)
+ (widget-glyph-insert-glyph widget tag (make-glyph file))
+ ;; File not readable, give up.
+ (insert tag)))
+ ;; We don't want or can't use glyphs.
+ (insert tag)))
+
+(defun widget-glyph-insert-glyph (widget tag glyph)
+ "In WIDGET, with alternative text TAG, insert GLYPH."
+ (set-glyph-image glyph (cons 'tty tag))
+ (set-glyph-property glyph 'widget widget)
+ (insert "*")
+ (add-text-properties (1- (point)) (point)
+ (list 'invisible t
+ 'end-glyph glyph)))
+
;;; Creating Widgets.
;;;###autoload
widget))
(defun widget-create-child (parent type)
- "Create widget of TYPE. "
+ "Create widget of TYPE."
+ (let ((widget (copy-list type)))
+ (widget-put widget :parent parent)
+ (unless (widget-get widget :indent)
+ (widget-put widget :indent (+ (or (widget-get parent :indent) 0)
+ (or (widget-get widget :extra-offset) 0)
+ (widget-get parent :offset))))
+ (widget-apply widget :create)
+ widget))
+
+(defun widget-create-child-value (parent type value)
+ "Create widget of TYPE with value VALUE."
(let ((widget (copy-list type)))
+ (widget-put widget :value (widget-apply widget :value-to-internal value))
(widget-put widget :parent parent)
(unless (widget-get widget :indent)
(widget-put widget :indent (+ (or (widget-get parent :indent) 0)
+ (or (widget-get widget :extra-offset) 0)
(widget-get parent :offset))))
(widget-apply widget :create)
widget))
"Keymap containing useful binding for buffers containing widgets.
Recommended as a parent keymap for modes using widgets.")
-(if widget-keymap
- ()
+(unless widget-keymap
(setq widget-keymap (make-sparse-keymap))
- (set-keymap-parent widget-keymap global-map)
+ (define-key widget-keymap "\C-k" 'widget-kill-line)
(define-key widget-keymap "\t" 'widget-forward)
(define-key widget-keymap "\M-\t" 'widget-backward)
(define-key widget-keymap [(shift tab)] 'widget-backward)
+ (define-key widget-keymap [(shift tab)] 'widget-backward)
+ (define-key widget-keymap [backtab] 'widget-backward)
(if (string-match "XEmacs" (emacs-version))
- (define-key widget-keymap [button2] 'widget-button-click)
- (define-key widget-keymap [menu-bar] 'nil)
- (define-key widget-keymap [mouse-2] 'widget-button-click))
+ (progn
+ (define-key widget-keymap [button2] 'widget-button-click)
+ (define-key widget-keymap [button1] 'widget-button1-click))
+ (define-key widget-keymap [mouse-2] 'ignore)
+ (define-key widget-keymap [down-mouse-2] 'widget-button-click))
(define-key widget-keymap "\C-m" 'widget-button-press))
(defvar widget-global-map global-map
"Keymap used for events the widget does not handle themselves.")
(make-variable-buffer-local 'widget-global-map)
+(defvar widget-field-keymap nil
+ "Keymap used inside an editable field.")
+
+(unless widget-field-keymap
+ (setq widget-field-keymap (copy-keymap widget-keymap))
+ (unless (string-match "XEmacs" (emacs-version))
+ (define-key widget-field-keymap [menu-bar] 'nil))
+ (define-key widget-field-keymap "\C-m" 'widget-field-activate)
+ (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
+ (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
+ (set-keymap-parent widget-field-keymap global-map))
+
+(defvar widget-text-keymap nil
+ "Keymap used inside a text field.")
+
+(unless widget-text-keymap
+ (setq widget-text-keymap (copy-keymap widget-keymap))
+ (unless (string-match "XEmacs" (emacs-version))
+ (define-key widget-text-keymap [menu-bar] 'nil))
+ (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
+ (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
+ (set-keymap-parent widget-text-keymap global-map))
+
+(defun widget-field-activate (pos &optional event)
+ "Activate the ediable field at point."
+ (interactive "@d")
+ (let ((field (get-text-property pos 'field)))
+ (if field
+ (widget-apply field :action event)
+ (call-interactively
+ (lookup-key widget-global-map (this-command-keys))))))
+
(defun widget-button-click (event)
"Activate button below mouse pointer."
(interactive "@e")
- (widget-button-press (event-point event) event))
+ (cond ((and (fboundp 'event-glyph)
+ (event-glyph event))
+ (let ((widget (glyph-property (event-glyph event) 'widget)))
+ (if widget
+ (widget-apply widget :action event)
+ (message "You clicked on a glyph."))))
+ ((event-point event)
+ (let ((button (get-text-property (event-point event) 'button)))
+ (if button
+ (widget-apply button :action event)
+ (call-interactively
+ (or (lookup-key widget-global-map [ button2 ])
+ (lookup-key widget-global-map [ down-mouse-2 ])
+ (lookup-key widget-global-map [ mouse-2]))))))
+ (t
+ (message "You clicked somewhere weird."))))
+
+(defun widget-button1-click (event)
+ "Activate glyph below mouse pointer."
+ (interactive "@e")
+ (if (and (fboundp 'event-glyph)
+ (event-glyph event))
+ (let ((widget (glyph-property (event-glyph event) 'widget)))
+ (if widget
+ (widget-apply widget :action event)
+ (message "You clicked on a glyph.")))
+ (call-interactively (lookup-key widget-global-map (this-command-keys)))))
(defun widget-button-press (pos &optional event)
"Activate button at POS."
(interactive "@d")
- (let* ((button (get-text-property pos 'button)))
+ (let ((button (get-text-property pos 'button)))
(if button
(widget-apply button :action event)
- (call-interactively
- (lookup-key widget-global-map (this-command-keys))))))
+ (let ((command (lookup-key widget-global-map (this-command-keys))))
+ (when (commandp command)
+ (call-interactively command))))))
-(defun widget-forward (arg)
- "Move point to the next field or button.
-With optional ARG, move across that many fields."
- (interactive "p")
+(defun widget-move (arg)
+ "Move point to the ARG next field or button.
+ARG may be negative to move backward."
(while (> arg 0)
(setq arg (1- arg))
(let ((next (cond ((get-text-property (point) 'button)
(goto-char (max button field)))
(button (goto-char button))
(field (goto-char field)))))
- (widget-echo-help (point)))
+ (widget-echo-help (point))
+ (run-hooks 'widget-move-hook))
+
+(defun widget-forward (arg)
+ "Move point to the next field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (run-hooks 'widget-forward-hook)
+ (widget-move arg))
(defun widget-backward (arg)
"Move point to the previous field or button.
With optional ARG, move across that many fields."
(interactive "p")
- (widget-forward (- arg)))
+ (run-hooks 'widget-backward-hook)
+ (widget-move (- arg)))
+
+(defun widget-beginning-of-line ()
+ "Go to beginning of field or beginning of line, whichever is first."
+ (interactive)
+ (let ((bol (save-excursion (beginning-of-line) (point)))
+ (prev (previous-single-property-change (point) 'field)))
+ (goto-char (max bol (or prev bol)))))
+
+(defun widget-end-of-line ()
+ "Go to end of field or end of line, whichever is first."
+ (interactive)
+ (let ((bol (save-excursion (end-of-line) (point)))
+ (prev (next-single-property-change (point) 'field)))
+ (goto-char (min bol (or prev bol)))))
+
+(defun widget-kill-line ()
+ "Kill to end of field or end of line, whichever is first."
+ (interactive)
+ (let ((field (get-text-property (point) 'field))
+ (newline (save-excursion (search-forward "\n")))
+ (next (next-single-property-change (point) 'field)))
+ (if (and field (> newline next))
+ (kill-region (point) next)
+ (call-interactively 'kill-line))))
;;; Setting up the buffer.
(widget-apply field :notify field))))
(error (debug))))
+;;; Widget Functions
+;;
+;; These functions are used in the definition of multiple widgets.
+
+(defun widget-children-value-delete (widget)
+ "Delete all :children and :buttons in WIDGET."
+ (mapcar 'widget-delete (widget-get widget :children))
+ (widget-put widget :children nil)
+ (mapcar 'widget-delete (widget-get widget :buttons))
+ (widget-put widget :buttons nil))
+
+(defun widget-types-convert-widget (widget)
+ "Convert :args as widget types in WIDGET."
+ (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
+ widget)
+
;;; The `default' Widget.
(define-widget 'default nil
:offset 0
:format-handler 'widget-default-format-handler
:button-face-get 'widget-default-button-face-get
+ :sample-face-get 'widget-default-sample-face-get
:delete 'widget-default-delete
:value-set 'widget-default-value-set
:value-inline 'widget-default-value-inline
(widget-specify-insert
(let ((from (point))
(tag (widget-get widget :tag))
+ (glyph (widget-get widget :tag-glyph))
(doc (widget-get widget :doc))
button-begin button-end
+ sample-begin sample-end
doc-begin doc-end
value-pos)
(insert (widget-get widget :format))
(goto-char from)
- ;; Parse % escapes in format.
+ ;; Parse escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (aref (match-string 1) 0)))
(replace-match "" t t)
(setq button-begin (point)))
((eq escape ?\])
(setq button-end (point)))
+ ((eq escape ?\{)
+ (setq sample-begin (point)))
+ ((eq escape ?\})
+ (setq sample-end (point)))
((eq escape ?n)
(when (widget-get widget :indent)
(insert "\n")
(insert-char ? (widget-get widget :indent))))
((eq escape ?t)
- (if tag
- (insert tag)
- (let ((standard-output (current-buffer)))
- (princ (widget-get widget :value)))))
+ (cond (glyph
+ (widget-glyph-insert widget (or tag "image") glyph))
+ (tag
+ (insert tag))
+ (t
+ (let ((standard-output (current-buffer)))
+ (princ (widget-get widget :value))))))
((eq escape ?d)
(when doc
(setq doc-begin (point))
(setq value-pos (point))))
(t
(widget-apply widget :format-handler escape)))))
- ;; Specify button and doc, and insert value.
+ ;; Specify button, sample, and doc, and insert value.
(and button-begin button-end
(widget-specify-button widget button-begin button-end))
+ (and sample-begin sample-end
+ (widget-specify-sample widget sample-begin sample-end))
(and doc-begin doc-end
(widget-specify-doc widget doc-begin doc-end))
(when value-pos
;; Use :button-face or widget-button-face
(or (widget-get widget :button-face) 'widget-button-face))
+(defun widget-default-sample-face-get (widget)
+ ;; Use :sample-face.
+ (widget-get widget :sample-face))
+
(defun widget-default-delete (widget)
;; Remove widget from the buffer.
(let ((from (widget-get widget :from))
:format "%t\n")
(defun widget-item-convert-widget (widget)
- ;; Initialize :value and :tag from :args in WIDGET.
+ ;; Initialize :value from :args in WIDGET.
(let ((args (widget-get widget :args)))
(when args
(widget-put widget :value (widget-apply widget
;;; The `push-button' Widget.
+(defcustom widget-push-button-gui t
+ "If non nil, use GUI push buttons when available."
+ :group 'widgets
+ :type 'boolean)
+
+;; Cache already created GUI objects.
+(defvar widget-push-button-cache nil)
+
(define-widget 'push-button 'item
"A pushable button."
- :format "%[[%t]%]")
+ :value-create 'widget-push-button-value-create
+ :format "%[%v%]")
+
+(defun widget-push-button-value-create (widget)
+ ;; Insert text representing the `on' and `off' states.
+ (let* ((tag (or (widget-get widget :tag)
+ (widget-get widget :value)))
+ (text (concat "[" tag "]"))
+ (gui (cdr (assoc tag widget-push-button-cache))))
+ (if (and (fboundp 'make-gui-button)
+ (fboundp 'make-glyph)
+ widget-push-button-gui
+ (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 text
+ (make-glyph (car (aref gui 1)))))
+ (insert text))))
+
+(defun widget-gui-action (widget)
+ "Apply :action for WIDGET."
+ (widget-apply widget :action (this-command-keys)))
;;; The `link' Widget.
(define-widget 'link 'item
"An embedded link."
+ :help-echo "Push me to follow the link."
:format "%[_%t_%]")
;;; The `info-link' Widget.
(define-widget 'editable-field 'default
"An editable text field."
:convert-widget 'widget-item-convert-widget
+ :keymap widget-field-keymap
:format "%v"
:value ""
:action 'widget-field-action
+ :validate 'widget-field-validate
+ :valid-regexp ""
+ :error "No match"
:value-create 'widget-field-value-create
:value-delete 'widget-field-value-delete
:value-get 'widget-field-value-get
(widget-apply widget :notify widget event)
(widget-setup)))
+(defun widget-field-validate (widget)
+ ;; Valid if the content matches `:valid-regexp'.
+ (save-excursion
+ (let ((value (widget-apply widget :value-get))
+ (regexp (widget-get widget :valid-regexp)))
+ (if (string-match regexp value)
+ nil
+ widget))))
+
(defun widget-field-value-create (widget)
;; Create an editable text field.
(insert " ")
(let ((size (widget-get widget :size))
(value (widget-get widget :value))
(from (point)))
- (if (null size)
- (if (zerop (length value))
- (insert "")
- (insert value))
- (insert value)
- (if (< (length value) size)
- (insert-char ?\ (- size (length value)))))
+ (insert value)
+ (and size
+ (< (length value) size)
+ (insert-char ?\ (- size (length value))))
(unless (memq widget widget-field-list)
(setq widget-field-new (cons widget widget-field-new)))
(widget-put widget :value-to (copy-marker (point)))
(defun widget-field-value-delete (widget)
;; Remove the widget from the list of active editing fields.
(setq widget-field-list (delq widget widget-field-list))
- (set-marker (widget-get widget :value-from) nil)
- (set-marker (widget-get widget :value-to) nil))
+ ;; These are nil if the :format string doesn't contain `%v'.
+ (when (widget-get widget :value-from)
+ (set-marker (widget-get widget :value-from) nil))
+ (when (widget-get widget :value-from)
+ (set-marker (widget-get widget :value-to) nil)))
(defun widget-field-value-get (widget)
;; Return current text in editing field.
(let ((from (widget-get widget :value-from))
(to (widget-get widget :value-to))
(size (widget-get widget :size))
+ (secret (widget-get widget :secret))
(old (current-buffer)))
(if (and from to)
(progn
(> to from)
(eq (char-after (1- to)) ?\ ))
(setq to (1- to)))
- (prog1 (buffer-substring-no-properties from to)
- (set-buffer old)))
+ (let ((result (buffer-substring-no-properties from to)))
+ (when secret
+ (let ((index 0))
+ (while (< (+ from index) to)
+ (aset result index
+ (get-text-property (+ from index) 'secret))
+ (setq index (1+ index)))))
+ (set-buffer old)
+ result))
(widget-get widget :value))))
(defun widget-field-match (widget value)
;;; The `text' Widget.
(define-widget 'text 'editable-field
+ :keymap widget-text-keymap
"A multiline text area.")
;;; The `menu-choice' Widget.
(define-widget 'menu-choice 'default
"A menu of options."
- :convert-widget 'widget-choice-convert-widget
+ :convert-widget 'widget-types-convert-widget
:format "%[%t%]: %v"
:case-fold t
:tag "choice"
:void '(item :format "invalid (%t)\n")
:value-create 'widget-choice-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-choice-value-get
:value-inline 'widget-choice-value-inline
:action 'widget-choice-action
:match 'widget-choice-match
:match-inline 'widget-choice-match-inline)
-(defun widget-choice-convert-widget (widget)
- ;; Expand type args into widget objects.
-; (widget-put widget :args (mapcar (lambda (child)
-; (if (widget-get child ':converted)
-; child
-; (widget-put child ':converted t)
-; (widget-convert child)))
-; (widget-get widget :args)))
- (widget-put widget :args (mapcar 'widget-convert (widget-get widget :args)))
- widget)
-
(defun widget-choice-value-create (widget)
;; Insert the first choice that matches the value.
(let ((value (widget-get widget :value))
(setq current (car args)
args (cdr args))
(when (widget-apply current :match value)
- (widget-put widget :children (list (widget-create-child-and-convert
- widget current :value value)))
+ (widget-put widget :children (list (widget-create-child-value
+ widget current value)))
(widget-put widget :choice current)
(setq args nil
current nil)))
;;; The `toggle' Widget.
-(define-widget 'toggle 'menu-choice
+(define-widget 'toggle 'item
"Toggle between two states."
- :convert-widget 'widget-toggle-convert-widget
- :format "%v"
+ :format "%[%v%]\n"
+ :value-create 'widget-toggle-value-create
+ :action 'widget-toggle-action
+ :match (lambda (widget value) t)
:on "on"
:off "off")
-(defun widget-toggle-convert-widget (widget)
- ;; Create the types representing the `on' and `off' states.
- (let ((on-type (widget-get widget :on-type))
- (off-type (widget-get widget :off-type)))
- (unless on-type
- (setq on-type
- (list 'choice-item
- :value t
- :match (lambda (widget value) value)
- :tag (widget-get widget :on))))
- (unless off-type
- (setq off-type
- (list 'choice-item :value nil :tag (widget-get widget :off))))
- (widget-put widget :args (list on-type off-type)))
- widget)
-
+(defun widget-toggle-value-create (widget)
+ ;; Insert text representing the `on' and `off' states.
+ (if (widget-value widget)
+ (widget-glyph-insert widget
+ (widget-get widget :on)
+ (widget-get widget :on-glyph))
+ (widget-glyph-insert widget
+ (widget-get widget :off)
+ (widget-get widget :off-glyph))))
+
+(defun widget-toggle-action (widget &optional event)
+ ;; Toggle value.
+ (widget-value-set widget (not (widget-value widget)))
+ (widget-apply widget :notify widget event))
+
;;; The `checkbox' Widget.
(define-widget 'checkbox 'toggle
"A checkbox toggle."
- :convert-widget 'widget-item-convert-widget
- :on-type '(choice-item :format "%[[X]%]" t)
- :off-type '(choice-item :format "%[[ ]%]" nil))
+ :format "%[%v%]"
+ :on "[X]"
+ :on-glyph "check1"
+ :off "[ ]"
+ :off-glyph "check0")
;;; The `checklist' Widget.
(define-widget 'checklist 'default
"A multiple choice widget."
- :convert-widget 'widget-choice-convert-widget
+ :convert-widget 'widget-types-convert-widget
:format "%v"
:offset 4
:entry-format "%b %v"
:menu-tag "checklist"
:greedy nil
:value-create 'widget-checklist-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-checklist-value-get
:validate 'widget-checklist-validate
:match 'widget-checklist-match
(cond ((not chosen)
(widget-create-child widget type))
((widget-get type :inline)
- (widget-create-child-and-convert
- widget type :value (cdr chosen)))
+ (widget-create-child-value
+ widget type (cdr chosen)))
(t
- (widget-create-child-and-convert
- widget type :value (car (cdr chosen)))))))
+ (widget-create-child-value
+ widget type (car (cdr chosen)))))))
(t
(error "Unknown escape `%c'" escape)))))
;; Update properties.
(setq current (car args)
args (cdr args)
found (widget-match-inline current vals)))
- (and found current)))
+ (if found
+ current
+ nil)))
(defun widget-checklist-value-get (widget)
;; The values of all selected items.
(define-widget 'radio-button 'toggle
"A radio button for use in the `radio' widget."
:notify 'widget-radio-button-notify
- :on-type '(choice-item :format "%[(*)%]" t)
- :off-type '(choice-item :format "%[( )%]" nil))
+ :format "%[%v%]"
+ :on "(*)"
+ :on-glyph "radio1"
+ :off "( )"
+ :off-glyph "radio0")
(defun widget-radio-button-notify (widget child &optional event)
- ;; Notify the parent.
+ ;; Tell daddy.
(widget-apply (widget-get widget :parent) :action widget event))
;;; The `radio-button-choice' Widget.
(define-widget 'radio-button-choice 'default
"Select one of multiple options."
- :convert-widget 'widget-choice-convert-widget
+ :convert-widget 'widget-types-convert-widget
:offset 4
:format "%v"
:entry-format "%b %v"
:menu-tag "radio"
:value-create 'widget-radio-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-radio-value-get
:value-inline 'widget-radio-value-inline
:value-set 'widget-radio-value-set
:value (not (null chosen)))))
((eq escape ?v)
(setq child (if chosen
- (widget-create-child-and-convert
- widget type :value value)
+ (widget-create-child-value
+ widget type value)
(widget-create-child widget type))))
(t
(error "Unknown escape `%c'" escape)))))
(widget-put widget :children (nconc children (list child))))
child)))
-(defun widget-radio-value-delete (widget)
- ;; Delete the child widgets.
- (mapcar 'widget-delete (widget-get widget :children))
- (widget-put widget :children nil)
- (mapcar 'widget-delete (widget-get widget :buttons))
- (widget-put widget :buttons nil))
-
(defun widget-radio-value-get (widget)
;; Get value of the child widget.
(let ((chosen (widget-radio-chosen widget)))
;;; The `editable-list' Widget.
+(defcustom widget-editable-list-gui nil
+ "If non nil, use GUI push-buttons in editable list when available."
+ :type 'boolean
+ :group 'widgets)
+
(define-widget 'editable-list 'default
"A variable list of widgets of the same type."
- :convert-widget 'widget-choice-convert-widget
+ :convert-widget 'widget-types-convert-widget
:offset 12
:format "%v%i\n"
:format-handler 'widget-editable-list-format-handler
:entry-format "%i %d %v"
:menu-tag "editable-list"
:value-create 'widget-editable-list-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-editable-list-value-get
:validate 'widget-editable-list-validate
:match 'widget-editable-list-match
(defun widget-editable-list-format-handler (widget escape)
;; We recognize the insert button.
- (cond ((eq escape ?i)
- (and (widget-get widget :indent)
- (insert-char ? (widget-get widget :indent)))
- (widget-create-child-and-convert widget 'insert-button))
- (t
- (widget-default-format-handler widget escape))))
-
-;(defun widget-editable-list-format-handler (widget escape)
-; ;; We recognize the insert button.
-; (cond ((eq escape ?i)
-; (insert " ")
-; (backward-char 1)
-; (let* ((from (point))
-; (button (widget-create-child-and-convert
-; widget 'insert-button)))
-; (widget-specify-button button from (point)))
-; (forward-char 1))
-; (t
-; (widget-default-format-handler widget escape))))
+ (let ((widget-push-button-gui widget-editable-list-gui))
+ (cond ((eq escape ?i)
+ (and (widget-get widget :indent)
+ (insert-char ? (widget-get widget :indent)))
+ (widget-create-child-and-convert widget 'insert-button))
+ (t
+ (widget-default-format-handler widget escape)))))
(defun widget-editable-list-value-create (widget)
;; Insert all values
(defun widget-editable-list-entry-create (widget value conv)
;; Create a new entry to the list.
(let ((type (nth 0 (widget-get widget :args)))
+ (widget-push-button-gui widget-editable-list-gui)
child delete insert)
(widget-specify-insert
(save-excursion
widget 'delete-button)))
((eq escape ?v)
(if conv
- (setq child (widget-create-child-and-convert
- widget type :value value))
+ (setq child (widget-create-child-value
+ widget type value))
(setq child (widget-create-child widget type))))
(t
(error "Unknown escape `%c'" escape)))))
(define-widget 'group 'default
"A widget which group other widgets inside."
- :convert-widget 'widget-choice-convert-widget
+ :convert-widget 'widget-types-convert-widget
:format "%v"
:value-create 'widget-group-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-editable-list-value-get
:validate 'widget-editable-list-validate
:match 'widget-group-match
(push (cond ((null answer)
(widget-create-child widget arg))
((widget-get arg :inline)
- (widget-create-child-and-convert
- widget arg :value (car answer)))
+ (widget-create-child-value widget arg (car answer)))
(t
- (widget-create-child-and-convert
- widget arg :value (car (car answer)))))
+ (widget-create-child-value widget arg (car (car answer)))))
children))
(widget-put widget :children (nreverse children))))
:documentation-property (lambda (symbol)
(condition-case nil
(documentation symbol t)
- (error nil)))
- :value-delete 'widget-radio-value-delete
- :match (lambda (widget value) (symbolp value)))
+ (error nil))))
(define-widget 'variable-item 'item
"An immutable variable name."
:format "%v\n%h"
- :documentation-property 'variable-documentation
- :value-delete 'widget-radio-value-delete
- :match (lambda (widget value) (symbolp value)))
+ :documentation-property 'variable-documentation)
(define-widget 'string 'editable-field
"A string"
:tag "Character"
:value 0
:size 1
- :format "%t: %v\n"
+ :format "%{%t%}: %v\n"
:type-error "This field should contain a character"
:value-to-internal (lambda (widget value)
(if (integerp value)
(define-widget 'list 'group
"A lisp list."
:tag "List"
- :format "%t:\n%v")
+ :format "%{%t%}:\n%v")
(define-widget 'vector 'group
"A lisp vector."
:tag "Vector"
- :format "%t:\n%v"
+ :format "%{%t%}:\n%v"
:match 'widget-vector-match
:value-to-internal (lambda (widget value) (append value nil))
:value-to-external (lambda (widget value) (apply 'vector value)))
(define-widget 'cons 'group
"A cons-cell."
:tag "Cons-cell"
- :format "%t:\n%v"
+ :format "%{%t%}:\n%v"
:match 'widget-cons-match
:value-to-internal (lambda (widget value)
(list (car value) (cdr value)))
(define-widget 'radio 'radio-button-choice
"A union of several sexp types."
:tag "Choice"
- :format "%t:\n%v")
+ :format "%{%t%}:\n%v")
(define-widget 'repeat 'editable-list
"A variable length homogeneous list."
:tag "Repeat"
- :format "%t:\n%v%i\n")
+ :format "%{%t%}:\n%v%i\n")
(define-widget 'set 'checklist
"A list of members from a fixed set."
:tag "Set"
- :format "%t:\n%v")
+ :format "%{%t%}:\n%v")
(define-widget 'boolean 'toggle
"To be nil or non-nil, that is the question."
:tag "Boolean"
- :format "%t: %v")
+ :format "%{%t%}: %[%v%]\n")
;;; The `color' Widget.
:tag "Color"
:value "default"
:value-create 'widget-color-value-create
- :value-delete 'widget-radio-value-delete
+ :value-delete 'widget-children-value-delete
:value-get 'widget-color-value-get
:value-set 'widget-color-value-set
:action 'widget-color-action
(remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
(setq track-mouse nil))
+(defun widget-at (pos)
+ "The button or field at POS."
+ (or (get-text-property pos 'button)
+ (get-text-property pos 'field)))
+
(defun widget-echo-help (pos)
"Display the help echo for widget at POS."
- (let* ((widget (or (get-text-property pos 'button)
- (get-text-property pos 'field)))
+ (let* ((widget (widget-at pos))
(help-echo (and widget (widget-get widget :help-echo))))
(cond ((stringp help-echo)
(message "%s" help-echo))
projects / gnus / blobdiff