;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.71
+;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
;;; Commentary:
;;
;; See `widget.el'.
(require 'widget)
-(eval-and-compile
- (require 'cl))
+(eval-when-compile (require 'cl))
;;; Compatibility.
;; We have the old custom-library, hack around it!
(defmacro defgroup (&rest args) nil)
(defmacro defcustom (var value doc &rest args)
- `(defvar ,var ,value ,doc))
+ (` (defvar (, var) (, value) (, doc))))
(defmacro defface (&rest args) nil)
(define-widget-keywords :prefix :tag :load :link :options :type :group)
(when (fboundp 'copy-face)
(defface widget-field-face '((((class grayscale color)
(background light))
- (:background "light gray"))
+ (:background "gray85"))
(((class grayscale color)
(background dark))
(:background "dark gray"))
"Choose an item from a list.
First argument TITLE is the name of the list.
-Second argument ITEMS is an alist (NAME . VALUE).
+Second argument ITEMS is an list whose members are either
+ (NAME . VALUE), to indicate selectable items, or just strings to
+ indicate unselectable items.
Optional third argument EVENT is an input event.
The user is asked to choose between each NAME from the items alist,
(mapcar
(function
(lambda (x)
- (vector (car x) (list (car x)) t)))
+ (if (stringp x)
+ (vector x nil nil)
+ (vector (car x) (list (car x)) t))))
items)))))
(setq val (and val
(listp (event-object val))
(car (event-object val))))
(cdr (assoc val items))))
(t
+ (setq items (remove-if 'stringp items))
(let ((val (completing-read (concat title ": ") items nil t)))
(if (stringp val)
(let ((try (try-completion val items)))
(throw 'child child)))
nil)))
+;;; Helper functions.
+;;
+;; These are widget specific.
+
+;;;###autoload
+(defun widget-prompt-value (widget prompt &optional value unbound)
+ "Prompt for a value matching WIDGET, using PROMPT.
+The current value is assumed to be VALUE, unless UNBOUND is non-nil."
+ (unless (listp widget)
+ (setq widget (list widget)))
+ (setq widget (widget-convert widget))
+ (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
+ (unless (widget-apply widget :match answer)
+ (error "Value does not match %S type." (car widget)))
+ answer))
+
;;; Widget text specifications.
;;
;; These functions are for specifying text properties.
(defmacro widget-specify-insert (&rest form)
;; Execute FORM without inheriting any text properties.
- `(save-restriction
+ (`
+ (save-restriction
(let ((inhibit-read-only t)
result
after-change-functions)
(narrow-to-region (- (point) 2) (point))
(widget-specify-none (point-min) (point-max))
(goto-char (1+ (point-min)))
- (setq result (progn ,@form))
+ (setq result (progn (,@ form)))
(delete-region (point-min) (1+ (point-min)))
(delete-region (1- (point-max)) (point-max))
(goto-char (point-max))
- result)))
+ result))))
(defface widget-inactive-face '((((class grayscale color)
(background dark))
(unless (widget-get widget :inactive)
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face 'widget-inactive-face)
- (overlay-put overlay 'evaporate 't)
+ (overlay-put overlay 'evaporate t)
+ (overlay-put overlay 'priority 100)
(overlay-put overlay (if (string-match "XEmacs" emacs-version)
'read-only
'modification-hooks) '(widget-overlay-inactive))
(if (widget-apply widget :active)
(widget-apply widget :action event)
(error "Attempt to perform action on inactive widget")))
-
+
;;; Glyphs.
(defcustom widget-glyph-directory (concat data-directory "custom/")
(defun widget-create-child (parent type)
"Create widget of TYPE."
- (let ((widget (copy-list type)))
+ (let ((widget (copy-sequence type)))
(widget-put widget :parent parent)
(unless (widget-get widget :indent)
(widget-put widget :indent (+ (or (widget-get parent :indent) 0)
(defun widget-create-child-value (parent type value)
"Create widget of TYPE with value VALUE."
- (let ((widget (copy-list type)))
+ (let ((widget (copy-sequence type)))
(widget-put widget :value (widget-apply widget :value-to-internal value))
(widget-put widget :parent parent)
(unless (widget-get widget :indent)
;; Don't touch the type.
(let* ((widget (if (symbolp type)
(list type)
- (copy-list type)))
+ (copy-sequence type)))
(current widget)
(keys args))
;; First set the :args keyword.
(t
(error "No buttons or fields found"))))))
(setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
+ (if (or (and button (widget-get button :tab-order)
+ (< (widget-get button :tab-order) 0))
+ (and button (not (widget-apply button :active))))
(setq arg (1+ arg))))))
(while (< arg 0)
(if (= (point-min) (point))
(button (goto-char button))
(field (goto-char field)))
(setq button (widget-at (point)))
- (if (and button (widget-get button :tab-order)
- (< (widget-get button :tab-order) 0))
+ (if (or (and button (widget-get button :tab-order)
+ (< (widget-get button :tab-order) 0))
+ (and button (not (widget-apply button :active))))
(setq arg (1- arg)))))
(widget-echo-help (point))
(run-hooks 'widget-move-hook))
:activate 'widget-specify-active
:deactivate 'widget-default-deactivate
:action 'widget-default-action
- :notify 'widget-default-notify)
+ :notify 'widget-default-notify
+ :prompt-value 'widget-default-prompt-value)
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
- (widget-put widget :to to))))
+ (widget-put widget :to to)))
+ (widget-clear-undo))
(defun widget-default-format-handler (widget escape)
;; We recognize the %h escape by default.
;; Kludge: this doesn't need to be true for empty formats.
(delete-region from to))
(set-marker from nil)
- (set-marker to nil)))
+ (set-marker to nil))
+ (widget-clear-undo))
(defun widget-default-value-set (widget value)
;; Recreate widget with new value.
;; Pass notification to parent.
(widget-default-action widget event))
+(defun widget-default-prompt-value (widget prompt value unbound)
+ ;; Read an arbitrary value. Stolen from `set-variable'.
+;; (let ((initial (if unbound
+;; nil
+;; ;; It would be nice if we could do a `(cons val 1)' here.
+;; (prin1-to-string (custom-quote value))))))
+ (eval-minibuffer prompt ))
+
;;; The `item' Widget.
(define-widget 'item 'default
(define-widget 'push-button 'item
"A pushable button."
:value-create 'widget-push-button-value-create
+ :text-format "[%s]"
: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 "]"))
+ (text (format (widget-get widget :text-format) tag))
(gui (cdr (assoc tag widget-push-button-cache))))
(if (and (fboundp 'make-gui-button)
(fboundp 'make-glyph)
(defun widget-info-link-action (widget &optional event)
"Open the info node specified by WIDGET."
- (Info-goto-node (widget-value widget)))
+ (Info-goto-node (widget-value widget))
+ ;; Steal button release event.
+ (if (and (fboundp 'button-press-event-p)
+ (fboundp 'next-command-event))
+ ;; XEmacs
+ (and event
+ (button-press-event-p event)
+ (next-command-event))
+ ;; Emacs
+ (when (memq 'down (event-modifiers event))
+ (read-event))))
;;; The `url-link' Widget.
(widget-value-set widget
(widget-apply current :value-to-external
(widget-get current :value)))
- (widget-apply widget :notify widget event)
- (widget-setup)))
- ;; Notify parent.
- (widget-apply widget :notify widget event)
- (widget-clear-undo))
+ (widget-apply widget :notify widget event)
+ (widget-setup))))
(defun widget-choice-validate (widget)
;; Valid if we have made a valid choice.
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
(widget-apply widget :notify widget event))
-
+
;;; The `checkbox' Widget.
(define-widget 'checkbox 'toggle
(defun widget-checklist-match-inline (widget values)
;; Find the values which match a type in the checklist.
(let ((greedy (widget-get widget :greedy))
- (args (copy-list (widget-get widget :args)))
+ (args (copy-sequence (widget-get widget :args)))
found rest)
(while values
(let ((answer (widget-checklist-match-up args values)))
;; Find the vals which match a type in the checklist.
;; Return an alist of (TYPE MATCH).
(let ((greedy (widget-get widget :greedy))
- (args (copy-list (widget-get widget :args)))
+ (args (copy-sequence (widget-get widget :args)))
found)
(while vals
(let ((answer (widget-checklist-match-up args vals)))
(defun widget-editable-list-delete-at (widget child)
;; Delete child from list of children.
(save-excursion
- (let ((buttons (copy-list (widget-get widget :buttons)))
+ (let ((buttons (copy-sequence (widget-get widget :buttons)))
button
(inhibit-read-only t)
after-change-functions)
(define-widget 'const 'item
"An immutable sexp."
+ :prompt-value 'widget-const-prompt-value
:format "%t\n%d")
-(define-widget 'function-item 'item
+(defun widget-const-prompt-value (widget prompt value unbound)
+ ;; Return the value of the const.
+ (widget-value widget))
+
+(define-widget 'function-item 'const
"An immutable function name."
:format "%v\n%h"
:documentation-property (lambda (symbol)
(documentation symbol t)
(error nil))))
-(define-widget 'variable-item 'item
+(define-widget 'variable-item 'const
"An immutable variable name."
:format "%v\n%h"
:documentation-property 'variable-documentation)
(define-widget 'string 'editable-field
"A string"
+ :prompt-value 'widget-string-prompt-value
:tag "String"
:format "%[%t%]: %v")
+(defvar widget-string-prompt-value-history nil
+ "History of input to `widget-string-prompt-value'.")
+
+(defun widget-string-prompt-value (widget prompt value unbound)
+ ;; Read a string.
+ (read-string prompt (if unbound nil (cons value 1))
+ 'widget-string-prompt-value-history))
+
(define-widget 'regexp 'string
"A regular expression."
- ;; Should do validation.
+ :match 'widget-regexp-match
+ :validate 'widget-regexp-validate
:tag "Regexp")
+(defun widget-regexp-match (widget value)
+ ;; Match valid regexps.
+ (and (stringp value)
+ (condition-case data
+ (prog1 t
+ (string-match value ""))
+ (error nil))))
+
+(defun widget-regexp-validate (widget)
+ "Check that the value of WIDGET is a valid regexp."
+ (let ((val (widget-value widget)))
+ (condition-case data
+ (prog1 nil
+ (string-match val ""))
+ (error (widget-put widget :error (error-message-string data))
+ widget))))
+
(define-widget 'file 'string
"A file widget.
It will read a file name from the minibuffer when activated."
+ :prompt-value 'widget-file-prompt-value
:format "%[%t%]: %v"
:tag "File"
:action 'widget-file-action)
+(defun widget-file-prompt-value (widget prompt value unbound)
+ ;; Read file from minibuffer.
+ (abbreviate-file-name
+ (if unbound
+ (read-file-name prompt)
+ (let ((prompt2 (concat prompt "(default `" value "') "))
+ (dir (file-name-directory value))
+ (file (file-name-nondirectory value))
+ (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))
:validate 'widget-sexp-validate
:match (lambda (widget value) t)
:value-to-internal 'widget-sexp-value-to-internal
- :value-to-external (lambda (widget value) (read value)))
+ :value-to-external (lambda (widget value) (read value))
+ :prompt-value 'widget-sexp-prompt-value)
(defun widget-sexp-value-to-internal (widget value)
;; Use pp for printer representation.
(error (widget-put widget :error (error-message-string data))
widget)))))
+(defvar widget-sexp-prompt-value-history nil
+ "History of input to `widget-sexp-prompt-value'.")
+
+(defun widget-sexp-prompt-value (widget prompt value unbound)
+ ;; Read an arbitrary sexp.
+ (let ((found (read-string prompt
+ (if unbound nil (cons (prin1-to-string value) 1))
+ 'widget-sexp-prompt-value)))
+ (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
+ (erase-buffer)
+ (insert found)
+ (goto-char (point-min))
+ (let ((answer (read buffer)))
+ (unless (eobp)
+ (error "Junk at end of expression: %s"
+ (buffer-substring (point) (point-max))))
+ answer))))
+
(define-widget 'integer 'sexp
"An integer."
:tag "Integer"
:value 0
:size 1
:format "%{%t%}: %v\n"
- :type-error "This field should contain a character"
+ :valid-regexp "\\`.\\'"
+ :error "This field should contain a single character"
:value-to-internal (lambda (widget value)
(if (integerp value)
(char-to-string value)
(defun widget-vector-match (widget value)
(and (vectorp value)
(widget-group-match widget
- (widget-apply :value-to-internal widget value))))
+ (widget-apply widget :value-to-internal value))))
(define-widget 'cons 'group
"A cons-cell."
(define-widget 'boolean 'toggle
"To be nil or non-nil, that is the question."
:tag "Boolean"
+ :prompt-value 'widget-boolean-prompt-value
:format "%{%t%}: %[%v%]\n")
+(defun widget-boolean-prompt-value (widget prompt value unbound)
+ ;; Toggle a boolean.
+ (cond (unbound
+ (y-or-n-p prompt))
+ (value
+ (message "Off")
+ nil)
+ (t
+ (message "On")
+ t)))
+
;;; The `color' Widget.
(define-widget 'color-item 'choice-item