;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.9924
+;; 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
"Character position of the end of event if that exists, or nil."
(posn-point (event-end event))))
-(defalias 'widget-read-event (if (string-match "XEmacs" emacs-version)
+ (defalias 'widget-read-event (if (string-match "XEmacs" emacs-version)
'next-event
'read-event))
- ;; 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)
(or (memq 'click (event-modifiers event))
(memq 'drag (event-modifiers event))))))
+ (unless (fboundp 'functionp)
+ ;; Missing from Emacs 19.34 and earlier.
+ (defun functionp (object)
+ "Non-nil of OBJECT is a type of object that can be called as a function."
+ (or (subrp object) (byte-code-function-p object)
+ (eq (car-safe object) 'lambda)
+ (and (symbolp object) (fboundp object)))))
+
(unless (fboundp 'error-message-string)
;; Emacs function missing in XEmacs.
(defun error-message-string (obj)
(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
:link '(custom-manual "(widget)Top")
:link '(url-link :tag "Development Page"
"http://www.dina.kvl.dk/~abraham/custom/")
+ :link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-"
:group 'extensions
:group 'hypermedia)
:group 'widgets
:group 'faces)
+(defvar widget-documentation-face 'widget-documentation-face
+ "Face used for documentation strings in widges.
+This exists as a variable so it can be set locally in certain buffers.")
+
(defface widget-documentation-face '((((class color)
(background dark))
(:foreground "lime green"))
:group 'widget-documentation
:group 'widget-faces)
+(defvar widget-button-face 'widget-button-face
+ "Face used for buttons in widges.
+This exists as a variable so it can be set locally in certain buffers.")
+
(defface widget-button-face '((t (:bold t)))
"Face used for widget buttons."
:group 'widget-faces)
"Face used for editable fields."
:group 'widget-faces)
+(defface widget-single-line-field-face '((((class grayscale color)
+ (background light))
+ (:background "gray85"))
+ (((class grayscale color)
+ (background dark))
+ (:background "dim gray"))
+ (t
+ (:italic t)))
+ "Face used for editable fields spanning only a single line."
+ :group 'widget-faces)
+
+;;; This causes display-table to be loaded, and not usefully.
+;;;(defvar widget-single-line-display-table
+;;; (let ((table (make-display-table)))
+;;; (aset table 9 "^I")
+;;; (aset table 10 "^J")
+;;; table)
+;;; "Display table used for single-line editable fields.")
+
+;;;(when (fboundp 'set-face-display-table)
+;;; (set-face-display-table 'widget-single-line-field-face
+;;; widget-single-line-display-table))
+
;;; Utility functions.
;;
;; These are not really widget specific.
-(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.
- ;; Unlike `plist-get', this allows you to distinguish between a missing
- ;; property and a property with the value nil.
- ;; The value is actually the tail of PLIST whose car is PROP.
- (while (and plist (not (eq (car plist) prop)))
- (setq plist (cdr (cdr plist))))
- plist)
-
(defun widget-princ-to-string (object)
;; Return string representation of OBJECT, any Lisp object.
;; No quoting characters are used; no delimiters are printed around
:group 'widgets
:type 'integer)
+(defcustom widget-menu-minibuffer-flag (string-match "XEmacs" emacs-version)
+ "*Control how to ask for a choice from the keyboard.
+Non-nil means use the minibuffer;
+nil means read a single character."
+ :group 'widgets
+ :type 'boolean)
+
(defun widget-choose (title items &optional event)
"Choose an item from a list.
(stringp (car-safe (event-object val)))
(car (event-object val))))
(cdr (assoc val items))))
- (t
+ (widget-menu-minibuffer-flag
+ ;; Read the choice of name from the minibuffer.
(setq items (widget-remove-if 'stringp items))
(let ((val (completing-read (concat title ": ") items nil t)))
(if (stringp val)
(when (stringp try)
(setq val try))
(cdr (assoc val items)))
- nil)))))
+ nil)))
+ (t
+ ;; Construct a menu of the choices
+ ;; and then use it for prompting for a single character.
+ (let* ((overriding-terminal-local-map
+ (make-sparse-keymap))
+ map choice (next-digit ?0)
+ some-choice-enabled
+ value)
+ ;; Define SPC as a prefix char to get to this menu.
+ (define-key overriding-terminal-local-map " "
+ (setq map (make-sparse-keymap title)))
+ (save-excursion
+ (set-buffer (get-buffer-create " widget-choose"))
+ (erase-buffer)
+ (insert "Available choices:\n\n")
+ (while items
+ (setq choice (car items) items (cdr items))
+ (if (consp choice)
+ (let* ((name (car choice))
+ (function (cdr choice)))
+ (insert (format "%c = %s\n" next-digit name))
+ (define-key map (vector next-digit) function)
+ (setq some-choice-enabled t)))
+ ;; Allocate digits to disabled alternatives
+ ;; so that the digit of a given alternative never varies.
+ (setq next-digit (1+ next-digit)))
+ (insert "\nC-g = Quit"))
+ (or some-choice-enabled
+ (error "None of the choices is currently meaningful"))
+ (define-key map [?\C-g] 'keyboard-quit)
+ (define-key map [t] 'keyboard-quit)
+ (define-key map [?\M-\C-v] 'scroll-other-window)
+ (define-key map [?\M--] 'negative-argument)
+ (setcdr map (nreverse (cdr map)))
+ ;; Read a char with the menu, and return the result
+ ;; that corresponds to it.
+ (save-window-excursion
+ (let ((buf (get-buffer " widget-choose")))
+ (display-buffer buf)
+ (let ((cursor-in-echo-area t)
+ keys
+ (char 0)
+ (arg 1))
+ (while (not (or (and (>= char ?0) (< char next-digit))
+ (eq value 'keyboard-quit)))
+ ;; Unread a SPC to lead to our new menu.
+ (setq unread-command-events (cons ?\ unread-command-events))
+ (setq keys (read-key-sequence title))
+ (setq value (lookup-key overriding-terminal-local-map keys t)
+ char (string-to-char (substring keys 1)))
+ (cond ((eq value 'scroll-other-window)
+ (let ((minibuffer-scroll-window (get-buffer-window buf)))
+ (if (> 0 arg)
+ (scroll-other-window-down (window-height minibuffer-scroll-window))
+ (scroll-other-window))
+ (setq arg 1)))
+ ((eq value 'negative-argument)
+ (setq arg -1))
+ (t
+ (setq arg 1)))))))
+ (when (eq value 'keyboard-quit)
+ (error "Canceled"))
+ value))))
(defun widget-remove-if (predictate list)
(let (result (tail list))
;;
;; 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)
:type 'boolean
:group 'widgets)
+(defcustom widget-field-use-before-change
+ (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
+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)
;; 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.
(save-excursion
(goto-char to)
- (when widget-field-add-space
- (insert-and-inherit " "))
+ (cond ((null (widget-get widget :size))
+ (forward-char 1))
+ (widget-field-add-space
+ (insert-and-inherit " ")))
(setq to (point)))
- (if widget-field-add-space
- (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))
- (overlay (make-overlay from to nil nil t)))
+ (overlay (make-overlay from to nil
+ nil (or (not widget-field-add-space)
+ (widget-get widget :size)))))
(unless (or (stringp help-echo) (null help-echo))
(setq help-echo 'widget-mouse-help))
(widget-put widget :field-overlay overlay)
(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)))))
+ (let ((face (widget-apply widget :sample-face-get))
+ (overlay (make-overlay from to nil t nil)))
+ (overlay-put overlay 'face face)
+ (widget-put widget :sample-overlay overlay)))
+
(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)))
"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'."
- (setcdr widget (plist-put (cdr widget) property value)))
-
-(defun widget-get (widget property)
+(defun widget-get-indirect (widget property)
"In WIDGET, get the value of PROPERTY.
-The value could either be specified when the widget was created, or
-later with `widget-put'."
- (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))
+If the value is a symbol, return its binding.
+Otherwise, just return the value."
+ (let ((value (widget-get widget property)))
+ (if (symbolp value)
+ (symbol-value value)
+ value)))
(defun widget-member (widget property)
"Non-nil iff there is a definition in WIDGET for PROPERTY."
(widget-member (get (car widget) 'widget-type) property))
(t nil)))
-;;;###autoload
-(defun widget-apply (widget property &rest args)
- "Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra arguments to the function."
- (apply (widget-get widget property) widget args))
-
(defun widget-value (widget)
"Extract the current value of WIDGET."
(widget-apply widget
"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.
:type 'string
:group 'widget-button)
-(defun widget-button-insert-indirect (widget key)
- "Insert value of WIDGET's KEY property."
- (let ((val (widget-get widget key)))
- (while (and val (symbolp val))
- (setq val (symbol-value val)))
- (when val
- (insert val))))
-
;;; Creating Widgets.
;;;###autoload
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)
(let ((from (widget-get widget :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)
(set-marker to nil)
(when button
(delete-overlay button))
+ (when sample
+ (delete-overlay sample))
+ (when doc
+ (delete-overlay doc))
(when field
(delete-overlay field))
(mapcar 'widget-leave-text children)))
:group 'widget-faces)
(defun widget-button-click (event)
- "Invoke button below mouse pointer."
+ "Invoke the button that the mouse is pointing at, and move there."
(interactive "@e")
+ (mouse-set-point event)
(cond ((and (fboundp 'event-glyph)
(event-glyph event))
(widget-glyph-click event))
(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))
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)
- (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)))
+ (widget-add-change))
(defvar widget-field-last nil)
;; Last field containing point.
"Return the end of WIDGET's editing field."
(let ((overlay (widget-get widget :field-overlay)))
;; Don't subtract one if local-map works at the end of the overlay.
- (and overlay (if widget-field-add-space
+ (and overlay (if (or widget-field-add-space
+ (null (widget-get widget :size)))
(1- (overlay-end overlay))
(overlay-end overlay)))))
(setq found field))))
found))
-;; This is how, for example, a variable changes its state to "set"
-;; when it is being edited.
-(defun widget-before-change (from &rest ignore)
- (condition-case nil
- (let ((field (widget-field-find from)))
- (widget-apply field :notify field))
- (error (debug "After Change"))))
+(defun widget-before-change (from to)
+ ;; This is how, for example, a variable changes its state to `modified'.
+ ;; when it is being edited.
+ (unless inhibit-read-only
+ (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.
(unless (eq old secret)
(subst-char-in-region begin (1+ begin) old secret)
(put-text-property begin (1+ begin) 'secret old))
- (setq begin (1+ begin)))))))))
+ (setq begin (1+ begin)))))))
+ (widget-apply field :notify field)))
(error (debug "After Change"))))
;;; Widget Functions
(insert "%"))
((eq escape ?\[)
(setq button-begin (point))
- (widget-button-insert-indirect widget :button-prefix))
+ (insert (widget-get-indirect widget :button-prefix)))
((eq escape ?\])
- (widget-button-insert-indirect widget :button-suffix)
+ (insert (widget-get-indirect widget :button-suffix))
(setq button-end (point)))
((eq escape ?\{)
(setq sample-begin (point)))
(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)
(defun widget-default-button-face-get (widget)
;; Use :button-face or widget-button-face
- (or (widget-get widget :button-face) 'widget-button-face))
+ (or (widget-get widget :button-face)
+ (let ((parent (widget-get widget :parent)))
+ (if parent
+ (widget-apply parent :button-face-get)
+ widget-button-face))))
(defun widget-default-sample-face-get (widget)
;; Use :sample-face.
(to (widget-get widget :to))
(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 inactive-overlay))
(when button-overlay
(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))
(defun widget-default-value-set (widget value)
;; Recreate widget with new value.
- (save-excursion
- (goto-char (widget-get widget :from))
- (widget-apply widget :delete)
- (widget-put widget :value value)
- (widget-apply widget :create)))
+ (let* ((old-pos (point))
+ (from (copy-marker (widget-get widget :from)))
+ (to (copy-marker (widget-get widget :to)))
+ (offset (if (and (<= from old-pos) (<= old-pos to))
+ (if (>= old-pos (1- to))
+ (- old-pos to 1)
+ (- old-pos from)))))
+ ;;??? Bug: this ought to insert the new value before deleting the old one,
+ ;; so that markers on either side of the value automatically
+ ;; stay on the same side. -- rms.
+ (save-excursion
+ (goto-char (widget-get widget :from))
+ (widget-apply widget :delete)
+ (widget-put widget :value value)
+ (widget-apply widget :create))
+ (if offset
+ (if (< offset 0)
+ (goto-char (+ (widget-get widget :to) offset 1))
+ (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
(defun widget-default-value-inline (widget)
;; Wrap value in a list unless it is inline.
;; 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."
"Open the info node specified by WIDGET."
(Info-goto-node (widget-value widget)))
-;;; The `group-link' Widget.
-
-(define-widget 'group-link 'link
- "A link to a customization group."
- :create 'widget-group-link-create
- :action 'widget-group-link-action)
-
-(defun widget-group-link-create (widget)
- (let ((state (widget-get (widget-get widget :parent) :custom-state)))
- (if (eq state 'hidden)
- (widget-default-create widget))))
-
-(defun widget-group-link-action (widget &optional event)
- "Open the info node specified by WIDGET."
- (customize-group (widget-value widget)))
-
;;; The `url-link' Widget.
(define-widget 'url-link 'link
(require 'browse-url)
(funcall browse-url-browser-function (widget-value widget)))
+;;; The `function-link' Widget.
+
+(define-widget 'function-link 'link
+ "A link to an Emacs function."
+ :action 'widget-function-link-action)
+
+(defun widget-function-link-action (widget &optional event)
+ "Show the function specified by WIDGET."
+ (describe-function (widget-value widget)))
+
+;;; The `variable-link' Widget.
+
+(define-widget 'variable-link 'link
+ "A link to an Emacs variable."
+ :action 'widget-variable-link-action)
+
+(defun widget-variable-link-action (widget &optional event)
+ "Show the variable specified by WIDGET."
+ (describe-variable (widget-value widget)))
+
+;;; The `file-link' Widget.
+
+(define-widget 'file-link 'link
+ "A link to a file."
+ :action 'widget-file-link-action)
+
+(defun widget-file-link-action (widget &optional event)
+ "Find the file specified by WIDGET."
+ (find-file (widget-value widget)))
+
+;;; The `emacs-library-link' Widget.
+
+(define-widget 'emacs-library-link 'link
+ "A link to an Emacs Lisp library file."
+ :action 'widget-emacs-library-link-action)
+
+(defun widget-emacs-library-link-action (widget &optional event)
+ "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
:prompt-internal prompt initial history)))
(widget-apply widget :value-to-external answer))))
+(defvar widget-edit-functions nil)
+
(defun widget-field-action (widget &optional event)
- ;; Edit the value in the minibuffer.
- (let ((invalid (widget-apply widget :validate)))
- (let ((prompt (concat (widget-apply widget :menu-tag-get) ": "))
- (value (unless invalid
- (widget-value widget))))
- (let ((answer (widget-apply widget :prompt-value prompt value invalid) ))
- (widget-value-set widget answer)))
- (widget-setup)
- (widget-apply widget :notify widget event)))
+ ;; Move to next field.
+ (widget-forward 1)
+ (run-hook-with-args 'widget-edit-functions widget))
(defun widget-field-validate (widget)
;; Valid if the content matches `:valid-regexp'.
(let ((size (widget-get widget :size))
(value (widget-get widget :value))
(from (point))
+ ;; This is changed to a real overlay in `widget-setup'. We
+ ;; need the end points to behave differently until
+ ;; `widget-setup' is called.
(overlay (cons (make-marker) (make-marker))))
(widget-put widget :field-overlay overlay)
(insert value)
(widget-apply current :value-to-external
(widget-get current :value)))
(widget-setup)
- (widget-apply widget :notify widget event))))
+ (widget-apply widget :notify widget event)))
+ (run-hook-with-args 'widget-edit-functions widget))
(defun widget-choice-validate (widget)
;; Valid if we have made a valid choice.
(defun widget-toggle-action (widget &optional event)
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
- (widget-apply widget :notify widget event))
+ (widget-apply widget :notify widget event)
+ (run-hook-with-args 'widget-edit-functions widget))
;;; The `checkbox' Widget.
(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)
(widget-glyph-insert widget on "down" "down-pushed")
(widget-glyph-insert widget off "right" "right-pushed"))))
-(define-widget 'group-visibility 'item
- "An indicator and manipulator for hidden group contents."
- :format "%[%v%]"
- :create 'widget-group-visibility-create
- :button-prefix ""
- :button-suffix ""
- :on "Hide"
- :off "Show"
- :value-create 'widget-visibility-value-create
- :action 'widget-toggle-action
- :match (lambda (widget value) t))
-
-(defun widget-group-visibility-create (widget)
- (let ((visible (widget-value widget)))
- (if visible
- (insert "--------")))
- (widget-default-create widget))
-
;;; The `documentation-link' Widget.
;;
;; This is a helper widget for `documentation-string'.
(concat "Describe the `" (widget-get widget :value) "' symbol."))
(defun widget-documentation-link-action (widget &optional event)
- "Run apropos on WIDGET's value. Ignore optional argument EVENT."
- (apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'")))
+ "Display documentation for WIDGET's value. Ignore optional argument EVENT."
+ (let* ((string (widget-get widget :value))
+ (symbol (intern string)))
+ (if (and (fboundp symbol) (boundp symbol))
+ ;; If there are two doc strings, give the user a way to pick one.
+ (apropos (concat "\\`" (regexp-quote string) "\\'"))
+ (if (fboundp symbol)
+ (describe-function symbol)
+ (describe-variable symbol)))))
(defcustom widget-documentation-links t
"Add hyperlinks to documentation strings when non-nil."
"A regular expression."
:match 'widget-regexp-match
:validate 'widget-regexp-validate
+ ;; Doesn't work well with terminating newline.
+ ;; :value-face 'widget-single-line-field-face
:tag "Regexp")
(defun widget-regexp-match (widget value)
(define-widget 'file 'string
"A file widget.
It will read a file name from the minibuffer when invoked."
+ :complete-function 'widget-file-complete
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
- :tag "File"
- :action 'widget-file-action)
+ ;; Doesn't work well with terminating newline.
+ ;; :value-face 'widget-single-line-field-face
+ :tag "File")
+
+(defun widget-file-complete ()
+ "Perform completion on file name preceding point."
+ (interactive)
+ (let* ((end (point))
+ (beg (save-excursion
+ (skip-chars-backward "^ ")
+ (point)))
+ (pattern (buffer-substring beg end))
+ (name-part (file-name-nondirectory pattern))
+ (directory (file-name-directory pattern))
+ (completion (file-name-completion name-part directory)))
+ (cond ((eq completion t))
+ ((null completion)
+ (message "Can't find completion for \"%s\"" pattern)
+ (ding))
+ ((not (string= name-part completion))
+ (delete-region beg end)
+ (insert (expand-file-name completion directory)))
+ (t
+ (message "Making completion list...")
+ (let ((list (file-name-all-completions name-part directory)))
+ (setq list (sort list 'string<))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...%s" "done")))))
(defun widget-file-prompt-value (widget prompt value unbound)
;; Read file from minibuffer.
(must-match (widget-get widget :must-match)))
(read-file-name prompt2 dir nil must-match file)))))
-(defun widget-file-action (widget &optional event)
- ;; Read a file name from the minibuffer.
- (let* ((value (widget-value widget))
- (dir (file-name-directory value))
- (file (file-name-nondirectory value))
- (menu-tag (widget-apply widget :menu-tag-get))
- (must-match (widget-get widget :must-match))
- (answer (read-file-name (concat menu-tag ": (default `" value "') ")
- dir nil must-match file)))
- (widget-value-set widget (abbreviate-file-name answer))
- (widget-setup)
- (widget-apply widget :notify widget event)))
+;;;(defun widget-file-action (widget &optional event)
+;;; ;; Read a file name from the minibuffer.
+;;; (let* ((value (widget-value widget))
+;;; (dir (file-name-directory value))
+;;; (file (file-name-nondirectory value))
+;;; (menu-tag (widget-apply widget :menu-tag-get))
+;;; (must-match (widget-get widget :must-match))
+;;; (answer (read-file-name (concat menu-tag ": (default `" value "') ")
+;;; dir nil must-match file)))
+;;; (widget-value-set widget (abbreviate-file-name answer))
+;;; (widget-setup)
+;;; (widget-apply widget :notify widget event)))
(define-widget 'directory 'file
"A directory widget.
:tag "Symbol"
:format "%{%t%}: %v"
:match (lambda (widget value) (symbolp value))
+ :complete-function 'lisp-complete-symbol
:prompt-internal 'widget-symbol-prompt-internal
:prompt-match 'symbolp
:prompt-history 'widget-symbol-prompt-value-history
(buffer-substring (point) (point-max))))
answer)))))
-(define-widget 'integer 'sexp
+(define-widget 'restricted-sexp 'sexp
+ "A Lisp expression restricted to values that match.
+To use this type, you must define :match or :match-alternatives."
+ :type-error "The specified value is not valid"
+ :match 'widget-restricted-sexp-match
+ :value-to-internal (lambda (widget value)
+ (if (widget-apply widget :match value)
+ (prin1-to-string value)
+ value)))
+
+(defun widget-restricted-sexp-match (widget value)
+ (let ((alternatives (widget-get widget :match-alternatives))
+ matched)
+ (while (and alternatives (not matched))
+ (if (cond ((functionp (car alternatives))
+ (funcall (car alternatives) value))
+ ((and (consp (car alternatives))
+ (eq (car (car alternatives)) 'quote))
+ (eq value (nth 1 (car alternatives)))))
+ (setq matched t))
+ (setq alternatives (cdr alternatives)))
+ matched))
+
+(define-widget 'integer 'restricted-sexp
"An integer."
:tag "Integer"
:value 0
:type-error "This field should contain an integer"
- :value-to-internal (lambda (widget value)
- (if (integerp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (integerp value)))
+ :match-alternatives '(integerp))
+
+(define-widget 'number 'restricted-sexp
+ "A floating point number."
+ :tag "Number"
+ :value 0.0
+ :type-error "This field should contain a number"
+ :match-alternatives '(numberp))
(define-widget 'character 'editable-field
- "An character."
+ "A character."
:tag "Character"
:value 0
:size 1
(characterp value)
(integerp value))))
-(define-widget 'number 'sexp
- "A floating point number."
- :tag "Number"
- :value 0.0
- :type-error "This field should contain a number"
- :value-to-internal (lambda (widget value)
- (if (numberp value)
- (prin1-to-string value)
- value))
- :match (lambda (widget value) (numberp value)))
-
(define-widget 'list 'group
"A lisp list."
:tag "List"
;;; The `color' Widget.
-(define-widget 'color-item 'choice-item
- "A color name (with sample)."
- :format "%v (%{sample%})\n"
- :sample-face-get 'widget-color-item-button-face-get)
-
-(defun widget-color-item-button-face-get (widget)
- (let ((symbol (intern (concat "fg:" (widget-value widget)))))
+(define-widget 'color 'editable-field
+ "Choose a color name (with sample)."
+ :format "%t: %v (%{sample%})\n"
+ :size 10
+ :tag "Color"
+ :value "black"
+ :complete 'widget-color-complete
+ :sample-face-get 'widget-color-sample-face-get
+ :notify 'widget-color-notify
+ :action 'widget-color-action)
+
+(defun widget-color-complete (widget)
+ "Complete the color in WIDGET."
+ (let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
+ (point)))
+ (list (widget-color-choice-list))
+ (completion (try-completion prefix list)))
+ (cond ((eq completion t)
+ (message "Exact match."))
+ ((null completion)
+ (error "Can't find completion for \"%s\"" prefix))
+ ((not (string-equal prefix completion))
+ (insert-and-inherit (substring completion (length prefix))))
+ (t
+ (message "Making completion list...")
+ (let ((list (all-completions prefix list nil)))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...done")))))
+
+(defun widget-color-sample-face-get (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)))))
-(define-widget 'color 'push-button
- "Choose a color name (with sample)."
- :format "%[%t%]: %v"
- :tag "Color"
- :value "black"
- :value-create 'widget-color-value-create
- :value-delete 'widget-children-value-delete
- :value-get 'widget-color-value-get
- :value-set 'widget-color-value-set
- :action 'widget-color-action
- :match 'widget-field-match
- :tag "Color")
-
(defvar widget-color-choice-list nil)
;; Variable holding the possible colors.
(defun widget-color-choice-list ()
(unless widget-color-choice-list
(setq widget-color-choice-list
- (mapcar '(lambda (color) (list color))
- (x-defined-colors))))
+ (if (fboundp 'read-color-completion-table)
+ (read-color-completion-table)
+ (mapcar '(lambda (color) (list color))
+ (x-defined-colors)))))
widget-color-choice-list)
-(defun widget-color-value-create (widget)
- (let ((child (widget-create-child-and-convert
- widget 'color-item (widget-get widget :value))))
- (widget-put widget :children (list child))))
-
-(defun widget-color-value-get (widget)
- ;; Pass command to first child.
- (widget-apply (car (widget-get widget :children)) :value-get))
-
-(defun widget-color-value-set (widget value)
- ;; Pass command to first child.
- (widget-apply (car (widget-get widget :children)) :value-set value))
-
(defvar widget-color-history nil
"History of entered colors")
;; 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)
(widget-apply widget :notify widget event))))
+(defun widget-color-notify (widget child &optional event)
+ "Update the sample, and notofy the parent."
+ (overlay-put (widget-get widget :sample-overlay)
+ 'face (widget-apply widget :sample-face-get))
+ (widget-default-notify widget child event))
+
;;; The Help Echo
(defun widget-echo-help-mouse ()
HCoop / bpt / emacs.git / blobdiff