comparison lisp/wid-edit.el @ 17799:0df9495348e7

Synched with 1.97.

17798:f59c9a63514b

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; 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

	  (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))

    (when (fboundp 'copy-face)
      (copy-face 'default 'widget-documentation-face)
      (copy-face 'bold 'widget-button-face)
      (copy-face 'italic 'widget-field-face)))

  (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))))

  (unless (fboundp 'error-message-string)
    ;; Emacs function missing in XEmacs.
    (defun error-message-string (obj)
      "Convert an error value to an error message."

			     (t 
			      (:italic t)))
  "Face used for editable fields."
  :group 'widgets)

(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.

(defsubst widget-plist-member (plist prop)

(defun widget-clear-undo ()
  "Clear all undo information."
  (buffer-disable-undo (current-buffer))
  (buffer-enable-undo))

(defun widget-choose (title items &optional event)
  "Choose an item from a list.

First argument TITLE is the name of the list.

		 (when (stringp try)
		   (setq val try))
		 (cdr (assoc val items)))
	     nil)))))

(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)))

;;; 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. 

(defun widget-specify-none (from to)

(defun widget-apply-action (widget &optional event)
  "Apply :action in WIDGET in response to EVENT."
  (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/")
  "Where widget glyphs are located.

	   (if (file-readable-p file)
	       (widget-glyph-insert-glyph widget tag (make-glyph file))
	     ;; File not readable, give up.
	     (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))
  (let ((help-echo (widget-get widget :help-echo)))
    (when help-echo
      (let ((extent (extent-at (1- (point)) nil 'end-glyph))
	    (help-property (if (featurep 'balloon-help)
			       'balloon-help

  (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 [backtab] 'widget-backward)
  (if (string-match "XEmacs" (emacs-version))
      (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.")

    (if field
	(widget-apply-action field event)
      (call-interactively
       (lookup-key widget-global-map (this-command-keys))))))

(defun widget-button-click (event)
  "Activate button below mouse pointer."
  (interactive "@e")
  (cond ((and (fboundp 'event-glyph)
	      (event-glyph event))
	 (let ((widget (glyph-property (event-glyph event) 'widget)))
	   (if widget
	       (widget-apply-action widget event)
	     (message "You clicked on a glyph."))))
	((event-point event)
	 (let ((button (get-text-property (event-point event) 'button)))
	   (if button
	       (widget-apply-action button 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

(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-action widget 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)))

;;; 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
  "Basic widget other widgets are derived from."

  :menu-tag-get 'widget-default-menu-tag-get
  :validate (lambda (widget) nil)
  :active 'widget-default-active
  :activate 'widget-specify-active
  :deactivate 'widget-default-deactivate
  :action 'widget-default-action
  :notify 'widget-default-notify
  :prompt-value 'widget-default-prompt-value)

(defun widget-default-create (widget)

;;; The `item' Widget.

(define-widget 'item 'default
  "Constant items for inclusion in other widgets."
  :convert-widget 'widget-item-convert-widget
  :value-create 'widget-item-value-create
  :value-delete 'ignore
  :value-get 'widget-item-value-get
  :match 'widget-item-match
  :match-inline 'widget-item-match-inline
  :action 'widget-item-action
  :format "%t\n")

(defun widget-item-convert-widget (widget)
  ;; Initialize :value from :args in WIDGET.
  (let ((args (widget-get widget :args)))
    (when args 
      (widget-put widget :value (widget-apply widget
					      :value-to-internal (car args)))
      (widget-put widget :args nil)))
  widget)

(defun widget-item-value-create (widget)
  ;; Insert the printed representation of the value.
  (let ((standard-output (current-buffer)))
    (princ (widget-get widget :value))))

		(cons head (subseq values (length value))))))))

(defun widget-item-action (widget &optional event)
  ;; Just notify itself.
  (widget-apply widget :notify widget event))

(defun widget-item-value-get (widget)
  ;; Items are simple.
  (widget-get widget :value))

;;; The `push-button' Widget.

(defcustom widget-push-button-gui t
  "If non nil, use GUI push buttons when available."

	(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-action widget (this-command-keys)))

  "A link to an info file."
  :action 'widget-info-link-action)

(defun widget-info-link-action (widget &optional event)
  "Open the info node specified by 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.

(define-widget 'url-link 'link
  "A link to an www page."

;;; The `editable-field' 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
  :match 'widget-field-match)

;; History of field minibuffer edits.
(defvar widget-field-history nil)

(defun widget-field-action (widget &optional event)
  ;; Edit the value in the minibuffer.
  (let ((tag (widget-apply widget :menu-tag-get))
	(invalid (widget-apply widget :validate)))
    (when invalid
      (error (widget-get invalid :error)))
    (widget-value-set widget 
		      (widget-apply widget 
				    :value-to-external
				    (read-string (concat tag ": ") 
						 (widget-apply 
						  widget
						  :value-to-internal
						  (widget-value widget))
						 'widget-field-history)))
    (widget-apply widget :notify widget event)
    (widget-setup)))

(defun widget-field-validate (widget)
  ;; Valid if the content matches `:valid-regexp'.

		      (not (zerop size))
		      (> to from)
		      (eq (char-after (1- to)) ?\ ))
	    (setq to (1- to)))
	  (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))

  :void '(item :format "invalid (%t)\n")
  :value-create 'widget-choice-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-choice-value-get
  :value-inline 'widget-choice-value-inline
  :action 'widget-choice-action
  :error "Make a choice"
  :validate 'widget-choice-validate
  :match 'widget-choice-match
  :match-inline 'widget-choice-match-inline)

(defun widget-choice-value-inline (widget)
  ;; Get value of the child widget.
  (widget-apply (car (widget-get widget :children)) :value-inline))

(defun widget-choice-action (widget &optional event)
  ;; Make a choice.
  (let ((args (widget-get widget :args))
	(old (widget-get widget :choice))
	(tag (widget-apply widget :menu-tag-get))

    (setq current
	  (cond ((= (length args) 0)
		 nil)
		((= (length args) 1)
		 (nth 0 args))
		((and (= (length args) 2)
		      (memq old args))
		 (if (eq old (nth 0 args))
		     (nth 1 args)
		   (nth 0 args)))
		(t

;;; The `choice-item' Widget.

(define-widget 'choice-item 'item
  "Button items that delegate action events to their parents."
  :action 'widget-choice-item-action
  :format "%[%t%] \n")

(defun widget-choice-item-action (widget &optional event)
  ;; Tell parent what happened.
  (widget-apply (widget-get widget :parent) :action event))

;;; The `radio-button' Widget.

(define-widget 'radio-button 'toggle
  "A radio button for use in the `radio' widget."

  :entry-format "%i %d %v"
  :menu-tag "editable-list"
  :value-create 'widget-editable-list-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get
  :validate 'widget-editable-list-validate
  :match 'widget-editable-list-match
  :match-inline 'widget-editable-list-match-inline
  :insert-before 'widget-editable-list-insert-before
  :delete-at 'widget-editable-list-delete-at)

(defun widget-editable-list-value-get (widget)
  ;; Get value of the child widget.
  (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
			 (widget-get widget :children))))

(defun widget-editable-list-validate (widget)
  ;; All the chilren must be valid.
  (let ((children (widget-get widget :children))
	child found)
    (while (and children (not found))
      (setq child (car children)
	    children (cdr children)
	    found (widget-apply child :validate)))
    found))

(defun widget-editable-list-match (widget value)
  ;; Value must be a list and all the members must match the type.
  (and (listp value)
       (null (cdr (widget-editable-list-match-inline widget value)))))

  :convert-widget 'widget-types-convert-widget
  :format "%v"
  :value-create 'widget-group-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get
  :validate 'widget-editable-list-validate
  :match 'widget-group-match
  :match-inline 'widget-group-match-inline)

(defun widget-group-value-create (widget)
  ;; Create each component.

(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."
  :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)

(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)))))

(define-widget 'directory 'file
  "A directory widget.  
It will read a directory name from the minibuffer when activated."
  :tag "Directory")

(define-widget 'symbol 'string
  "A lisp symbol."
  :value nil
  :tag "Symbol"
  :match (lambda (widget value) (symbolp value))
  :value-to-internal (lambda (widget value)
		       (if (symbolp value)
			   (symbol-name value)
			 value))
  :value-to-external (lambda (widget value)
		       (if (stringp value)
			   (intern value)
			 value)))

(define-widget 'function 'sexp
  ;; Should complete on functions.
  "A lisp function."
  :tag "Function")

(define-widget 'variable 'symbol
  ;; Should complete on variables.
  "A lisp variable."
  :tag "Variable")

(define-widget 'sexp 'string
  "An arbitrary lisp expression."
  :tag "Lisp expression"
  :value nil
  :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))
  :prompt-value 'widget-sexp-prompt-value)

(defun widget-sexp-value-to-internal (widget value)
  ;; Use pp for printer representation.
  (let ((pp (pp-to-string value)))

  "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
  :type-error "This field should contain an integer"

		       (if (integerp value) 
			   (prin1-to-string value)
			 value))
  :match (lambda (widget value) (integerp value)))

(define-widget 'character 'string
  "An character."
  :tag "Character"
  :value 0
  :size 1 
  :format "%{%t%}: %v\n"
  :valid-regexp "\\`.\\'"
  :error "This field should contain a single character"
  :value-to-internal (lambda (widget value)
		       (if (integerp value) 
			   (char-to-string value)
			 value))
  :value-to-external (lambda (widget value)
		       (if (stringp value)
			   (aref value 0)
			 value))
  :match (lambda (widget value) (integerp value)))

(define-widget 'number 'sexp
  "A floating point number."
  :tag "Number"
  :value 0.0

			   (widget-apply widget :value-to-internal value))))

(define-widget 'choice 'menu-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%[%t%]: %v")

(define-widget 'radio 'radio-button-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}:\n%v")

(define-widget 'repeat 'editable-list
  "A variable length homogeneous list."
  :tag "Repeat"
  :format "%{%t%}:\n%v%i\n")

(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
  "A color name (with sample)."

17799:0df9495348e7

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.97
;; 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

	  (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)))
	  
  (if (string-match "XEmacs" emacs-version)
      (defun widget-event-point (event)
	"Character position of the end of event if that exists, or nil."
	(if (mouse-event-p event)
	    (event-point event)
	  nil))
    (defun widget-event-point (event)
      "Character position of the end of event if that exists, or nil."
      (posn-point (event-end event))))

;; The following should go away when bundled with Emacs.
  (condition-case ()
      (require 'custom)
    (error nil))

    (when (fboundp 'copy-face)
      (copy-face 'default 'widget-documentation-face)
      (copy-face 'bold 'widget-button-face)
      (copy-face 'italic 'widget-field-face)))

  (unless (fboundp 'button-release-event-p)
    ;; XEmacs function missing from Emacs.
    (defun button-release-event-p (event)
      "Non-nil if EVENT is a mouse-button-release event object."
      (and (eventp event)
	   (memq (event-basic-type event) '(mouse-1 mouse-2 mouse-3))
	   (or (memq 'click (event-modifiers event))
	       (memq  'drag (event-modifiers event))))))

  (unless (fboundp 'error-message-string)
    ;; Emacs function missing in XEmacs.
    (defun error-message-string (obj)
      "Convert an error value to an error message."

			     (t 
			      (:italic t)))
  "Face used for editable fields."
  :group 'widgets)

;;; Utility functions.
;;
;; These are not really widget specific.

(defsubst widget-plist-member (plist prop)

(defun widget-clear-undo ()
  "Clear all undo information."
  (buffer-disable-undo (current-buffer))
  (buffer-enable-undo))

(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)

(defun widget-choose (title items &optional event)
  "Choose an item from a list.

First argument TITLE is the name of the list.

		 (when (stringp try)
		   (setq val try))
		 (cdr (assoc val items)))
	     nil)))))

;;; Widget text specifications.
;; 
;; These functions are for specifying text properties. 

(defun widget-specify-none (from to)

(defun widget-apply-action (widget &optional event)
  "Apply :action in WIDGET in response to EVENT."
  (if (widget-apply widget :active)
      (widget-apply widget :action event)
    (error "Attempt to perform action on inactive widget")))

;;; 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 prompt (format "[%s] %s" (widget-type widget) prompt))
  (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))

(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)))

;;; Glyphs.

(defcustom widget-glyph-directory (concat data-directory "custom/")
  "Where widget glyphs are located.

	   (if (file-readable-p file)
	       (widget-glyph-insert-glyph widget tag (make-glyph file))
	     ;; File not readable, give up.
	     (insert tag))))))

(defun widget-glyph-insert-glyph (widget tag glyph &optional down inactive)
  "In WIDGET, with alternative text TAG, insert GLYPH."
  (set-glyph-image glyph (cons 'tty tag))
  (set-glyph-property glyph 'widget widget)
  (when down
    (set-glyph-image down (cons 'tty tag))
    (set-glyph-property down 'widget widget))
  (when inactive
    (set-glyph-image inactive (cons 'tty tag))
    (set-glyph-property inactive 'widget widget))
  (insert "*")
  (add-text-properties (1- (point)) (point) 
		       (list 'invisible t
			     'end-glyph glyph))
  (widget-put widget :glyph-up glyph)
  (when down (widget-put widget :glyph-down down))
  (when inactive (widget-put widget :glyph-inactive inactive))
  (let ((help-echo (widget-get widget :help-echo)))
    (when help-echo
      (let ((extent (extent-at (1- (point)) nil 'end-glyph))
	    (help-property (if (featurep 'balloon-help)
			       'balloon-help

  (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 [backtab] 'widget-backward)
  (if (string-match "XEmacs" emacs-version)
      (progn 
	;;Glyph support.
	(define-key widget-keymap [button1] 'widget-button1-click) 
	(define-key widget-keymap [button2] 'widget-button-click))
    (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.")

    (if field
	(widget-apply-action field event)
      (call-interactively
       (lookup-key widget-global-map (this-command-keys))))))

(defface widget-button-pressed-face 
  '((((class color))
     (:foreground "red"))
    (t
     (:bold t :underline t)))
  "Face used for pressed buttons."
  :group 'widgets)

(defun widget-button-click (event)
  "Activate button below mouse pointer."
  (interactive "@e")
  (cond ((and (fboundp 'event-glyph)
	      (event-glyph event))
	 (widget-glyph-click event))
	((widget-event-point event)
	 (let* ((pos (widget-event-point event))
		(button (get-text-property pos 'button)))
	   (if button
	       (let ((begin (previous-single-property-change (1+ pos) 'button))
		     (end (next-single-property-change pos 'button))
		     overlay)
		 (unwind-protect
		     (let ((track-mouse t))
		       (setq overlay (make-overlay begin end))
		       (overlay-put overlay 'face 'widget-button-pressed-face)
		       (overlay-put overlay 
				    'mouse-face 'widget-button-pressed-face)
		       (unless (widget-apply button :mouse-down-action event)
			 (while (not (button-release-event-p event))
			   (setq event (if (fboundp 'read-event)
					   (read-event)
					 (next-event))
				 pos (widget-event-point event))
			   (if (and pos
				    (eq (get-text-property pos 'button)
					button))
			       (progn 
				 (overlay-put overlay 
					      'face
					      'widget-button-pressed-face)
				 (overlay-put overlay 
					      'mouse-face 
					      'widget-button-pressed-face))
			     (overlay-put overlay 'face nil)
			     (overlay-put overlay 'mouse-face nil))))
		       
		       (when (and pos 
				  (eq (get-text-property pos 'button) button))
			 (widget-apply-action button event)))
		   (delete-overlay overlay)))
	     (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

(defun widget-button1-click (event)
  "Activate glyph below mouse pointer."
  (interactive "@e")
  (if (and (fboundp 'event-glyph)
	   (event-glyph event))
      (widget-glyph-click event)
    (call-interactively (lookup-key widget-global-map (this-command-keys)))))

(defun widget-glyph-click (event)
  "Handle click on a glyph."
  (let* ((glyph (event-glyph event))
	 (widget (glyph-property glyph 'widget))
	 (extent (event-glyph-extent event))
	 (down-glyph (or (and widget (widget-get widget :glyph-down)) glyph))
	 (up-glyph (or (and widget (widget-get widget :glyph-up)) glyph))
	 (last event))
    ;; Wait for the release.
    (while (not (button-release-event-p last))
      (if (eq extent (event-glyph-extent last))
	  (set-extent-property extent 'end-glyph down-glyph)
	(set-extent-property extent 'end-glyph up-glyph))
      (setq last (next-event event)))
    ;; Release glyph.
    (when down-glyph
      (set-extent-property extent 'end-glyph up-glyph))
    ;; Apply widget action.
    (when (eq extent (event-glyph-extent last))
      (let ((widget (glyph-property (event-glyph event) 'widget)))
	(cond ((null widget)
	       (message "You clicked on a glyph."))
	      ((not (widget-apply widget :active))
	       (message "This glyph is inactive."))
	      (t
	       (widget-apply-action widget event)))))))

(defun widget-button-press (pos &optional event)
  "Activate button at POS."
  (interactive "@d")
  (let ((button (get-text-property pos 'button)))

;;; Widget Functions
;;
;; These functions are used in the definition of multiple widgets. 

(defun widget-parent-action (widget &optional event)
  "Tell :parent of WIDGET to handle the :action.
Optional EVENT is the event that triggered the action."
  (widget-apply (widget-get widget :parent) :action event))

(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-children-validate (widget)
  "All the :children must be valid."
  (let ((children (widget-get widget :children))
	child found)
    (while (and children (not found))
      (setq child (car children)
	    children (cdr children)
	    found (widget-apply child :validate)))
    found))

(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)

(defun widget-value-convert-widget (widget)
  "Initialize :value from :args in WIDGET."
  (let ((args (widget-get widget :args)))
    (when args 
      (widget-put widget :value (car args))
      ;; Don't convert :value here, as this is done in `widget-convert'.
      ;; (widget-put widget :value (widget-apply widget
      ;;  				      :value-to-internal (car args)))
      (widget-put widget :args nil)))
  widget)

(defun widget-value-value-get (widget)
  "Return the :value property of WIDGET."
  (widget-get widget :value))

;;; The `default' Widget.

(define-widget 'default nil
  "Basic widget other widgets are derived from."

  :menu-tag-get 'widget-default-menu-tag-get
  :validate (lambda (widget) nil)
  :active 'widget-default-active
  :activate 'widget-specify-active
  :deactivate 'widget-default-deactivate
  :mouse-down-action (lambda (widget event) nil)
  :action 'widget-default-action
  :notify 'widget-default-notify
  :prompt-value 'widget-default-prompt-value)

(defun widget-default-create (widget)

;;; The `item' Widget.

(define-widget 'item 'default
  "Constant items for inclusion in other widgets."
  :convert-widget 'widget-value-convert-widget
  :value-create 'widget-item-value-create
  :value-delete 'ignore
  :value-get 'widget-value-value-get
  :match 'widget-item-match
  :match-inline 'widget-item-match-inline
  :action 'widget-item-action
  :format "%t\n")

(defun widget-item-value-create (widget)
  ;; Insert the printed representation of the value.
  (let ((standard-output (current-buffer)))
    (princ (widget-get widget :value))))

		(cons head (subseq values (length value))))))))

(defun widget-item-action (widget &optional event)
  ;; Just notify itself.
  (widget-apply widget :notify widget event))

;;; The `push-button' Widget.

(defcustom widget-push-button-gui t
  "If non nil, use GUI push buttons when available."

	(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 (nth 0 (aref gui 1)))
				     (make-glyph (nth 1 (aref gui 1)))
				     (make-glyph (nth 2 (aref gui 1)))))
      (insert text))))

(defun widget-gui-action (widget)
  "Apply :action for WIDGET."
  (widget-apply-action widget (this-command-keys)))

  "A link to an info file."
  :action 'widget-info-link-action)

(defun widget-info-link-action (widget &optional event)
  "Open the info node specified by WIDGET."
  (Info-goto-node (widget-value widget)))

;;; The `url-link' Widget.

(define-widget 'url-link 'link
  "A link to an www page."

;;; The `editable-field' Widget.

(define-widget 'editable-field 'default
  "An editable text field."
  :convert-widget 'widget-value-convert-widget
  :keymap widget-field-keymap
  :format "%v"
  :value ""
  :prompt-internal 'widget-field-prompt-internal
  :prompt-history 'widget-field-history
  :prompt-value 'widget-field-prompt-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
  :match 'widget-field-match)

(defvar widget-field-history nil
  "History of field minibuffer edits.")

(defun widget-field-prompt-internal (widget prompt initial history)
  ;; Read string for WIDGET promptinhg with PROMPT.
  ;; INITIAL is the initial input and HISTORY is a symbol containing
  ;; the earlier input.
  (read-string prompt initial history))

(defun widget-field-prompt-value (widget prompt value unbound)
  ;; Prompt for a string.
  (let ((initial (if unbound
		     nil
		   (cons (widget-apply widget :value-to-internal
				       value) 0)))
	(history (widget-get widget :prompt-history)))
    (let ((answer (widget-apply widget
				:prompt-internal prompt initial history)))
      (widget-apply widget :value-to-external answer))))

(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-apply widget :notify widget event)
    (widget-setup)))

(defun widget-field-validate (widget)
  ;; Valid if the content matches `:valid-regexp'.

		      (not (zerop size))
		      (> to from)
		      (eq (char-after (1- to)) ?\ ))
	    (setq to (1- to)))
	  (let ((result (buffer-substring-no-properties from to)))
	    (when (string-match "XEmacs" emacs-version)
	      ;; XEmacs 20.1 bug: b-s-n-p doesn't clear all properties. 
	      (setq result (format "%s" result)))
	    (when secret
	      (let ((index 0))
		(while (< (+ from index) to)
		  (aset result index
			(get-text-property (+ from index) 'secret))

  :void '(item :format "invalid (%t)\n")
  :value-create 'widget-choice-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-choice-value-get
  :value-inline 'widget-choice-value-inline
  :mouse-down-action 'widget-choice-mouse-down-action
  :action 'widget-choice-action
  :error "Make a choice"
  :validate 'widget-choice-validate
  :match 'widget-choice-match
  :match-inline 'widget-choice-match-inline)

(defun widget-choice-value-inline (widget)
  ;; Get value of the child widget.
  (widget-apply (car (widget-get widget :children)) :value-inline))

(defcustom widget-choice-toggle nil
  "If non-nil, a binary choice will just toggle between the values.
Otherwise, the user will explicitly have to choose between the values
when he activate the menu."
  :type 'boolean
  :group 'widgets)

(defun widget-choice-mouse-down-action (widget &optional event)
  ;; Return non-nil if we need a menu.
  (let ((args (widget-get widget :args))
	(old (widget-get widget :choice)))
    (cond ((not window-system)
	   ;; No place to pop up a menu.
	   nil)
	  ((not (or (fboundp 'x-popup-menu) (fboundp 'popup-menu)))
	   ;; No way to pop up a menu.
	   nil)
	  ((< (length args) 2)
	   ;; Empty or singleton list, just return the value.
	   nil)
	  ((> (length args) widget-menu-max-size)
	   ;; Too long, prompt.
	   nil)
	  ((> (length args) 2)
	   ;; Reasonable sized list, use menu.
	   t)
	  ((and widget-choice-toggle (memq old args))
	   ;; We toggle.
	   nil)
	  (t
	   ;; Ask which of the two.
	   t))))

(defun widget-choice-action (widget &optional event)
  ;; Make a choice.
  (let ((args (widget-get widget :args))
	(old (widget-get widget :choice))
	(tag (widget-apply widget :menu-tag-get))

    (setq current
	  (cond ((= (length args) 0)
		 nil)
		((= (length args) 1)
		 (nth 0 args))
		((and widget-choice-toggle
		      (= (length args) 2)
		      (memq old args))
		 (if (eq old (nth 0 args))
		     (nth 1 args)
		   (nth 0 args)))
		(t

;;; The `choice-item' Widget.

(define-widget 'choice-item 'item
  "Button items that delegate action events to their parents."
  :action 'widget-parent-action
  :format "%[%t%] \n")

;;; The `radio-button' Widget.

(define-widget 'radio-button 'toggle
  "A radio button for use in the `radio' widget."

  :entry-format "%i %d %v"
  :menu-tag "editable-list"
  :value-create 'widget-editable-list-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get
  :validate 'widget-children-validate
  :match 'widget-editable-list-match
  :match-inline 'widget-editable-list-match-inline
  :insert-before 'widget-editable-list-insert-before
  :delete-at 'widget-editable-list-delete-at)

(defun widget-editable-list-value-get (widget)
  ;; Get value of the child widget.
  (apply 'append (mapcar (lambda (child) (widget-apply child :value-inline))
			 (widget-get widget :children))))

(defun widget-editable-list-match (widget value)
  ;; Value must be a list and all the members must match the type.
  (and (listp value)
       (null (cdr (widget-editable-list-match-inline widget value)))))

  :convert-widget 'widget-types-convert-widget
  :format "%v"
  :value-create 'widget-group-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-editable-list-value-get
  :validate 'widget-children-validate
  :match 'widget-group-match
  :match-inline 'widget-group-match-inline)

(defun widget-group-value-create (widget)
  ;; Create each component.

(define-widget 'variable-item 'const
  "An immutable variable name."
  :format "%v\n%h"
  :documentation-property 'variable-documentation)

(defvar widget-string-prompt-value-history nil
  "History of input to `widget-string-prompt-value'.")

(define-widget 'string 'editable-field
  "A string"
  :tag "String"
  :format "%{%t%}: %v"
  :prompt-history 'widget-string-prompt-value-history)

(define-widget 'regexp 'string
  "A regular expression."
  :match 'widget-regexp-match
  :validate 'widget-regexp-validate
  :tag "Regexp")

(defun widget-regexp-match (widget value)
  ;; Match valid regexps.
  (and (stringp value)
       (condition-case nil
	   (prog1 t
	     (string-match value ""))
	 (error nil))))

(defun widget-regexp-validate (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 (format "%s (default %s) " prompt 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)))))

(define-widget 'directory 'file
  "A directory widget.  
It will read a directory name from the minibuffer when activated."
  :tag "Directory")

(defvar widget-symbol-prompt-value-history nil
  "History of input to `widget-symbol-prompt-value'.")

(define-widget 'symbol 'editable-field
  "A lisp symbol."
  :value nil
  :tag "Symbol"
  :format "%{%t%}: %v"
  :match (lambda (widget value) (symbolp value))
  :prompt-internal 'widget-symbol-prompt-internal
  :prompt-match 'symbolp
  :prompt-history 'widget-symbol-prompt-value-history
  :value-to-internal (lambda (widget value)
		       (if (symbolp value)
			   (symbol-name value)
			 value))
  :value-to-external (lambda (widget value)
		       (if (stringp value)
			   (intern value)
			 value)))

(defun widget-symbol-prompt-internal (widget prompt initial history)
  ;; Read file from minibuffer.
  (let ((answer (completing-read prompt obarray 
				 (widget-get widget :prompt-match)
				 nil initial history)))
    (if (and (stringp answer)
	     (not (zerop (length answer))))
	answer
      (error "No value"))))

(defvar widget-function-prompt-value-history nil
  "History of input to `widget-function-prompt-value'.")

(define-widget 'function 'sexp
  "A lisp function."
  :prompt-value 'widget-field-prompt-value
  :prompt-internal 'widget-symbol-prompt-internal
  :prompt-match 'fboundp
  :prompt-history 'widget-function-prompt-value-history
  :action 'widget-field-action
  :tag "Function")

(defvar widget-variable-prompt-value-history nil
  "History of input to `widget-variable-prompt-value'.")

(define-widget 'variable 'symbol
  ;; Should complete on variables.
  "A lisp variable."
  :prompt-match 'boundp
  :prompt-history 'widget-variable-prompt-value-history
  :tag "Variable")

(define-widget 'sexp 'editable-field
  "An arbitrary lisp expression."
  :tag "Lisp expression"
  :format "%{%t%}: %v"
  :value nil
  :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))
  :prompt-history 'widget-sexp-prompt-value-history
  :prompt-value 'widget-sexp-prompt-value)

(defun widget-sexp-value-to-internal (widget value)
  ;; Use pp for printer representation.
  (let ((pp (pp-to-string value)))

  "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) 0))
			    (widget-get widget :prompt-history))))
    (save-excursion
      (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
  :type-error "This field should contain an integer"

		       (if (integerp value) 
			   (prin1-to-string value)
			 value))
  :match (lambda (widget value) (integerp value)))

(define-widget 'character 'editable-field
  "An character."
  :tag "Character"
  :value 0
  :size 1 
  :format "%{%t%}: %v\n"
  :valid-regexp "\\`.\\'"
  :error "This field should contain a single character"
  :value-to-internal (lambda (widget value)
		       (if (stringp value) 
			   value
			 (char-to-string value)))
  :value-to-external (lambda (widget value)
		       (if (stringp value)
			   (aref value 0)
			 value))
  :match (lambda (widget value)
	   (if (fboundp 'characterp)
	       (characterp value)
	     (integerp value))))

(define-widget 'number 'sexp
  "A floating point number."
  :tag "Number"
  :value 0.0

			   (widget-apply widget :value-to-internal value))))

(define-widget 'choice 'menu-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%[%t%]: %v"
  :prompt-value 'widget-choice-prompt-value)

(defun widget-choice-prompt-value (widget prompt value unbound)
  "Make a choice." 
  (let ((args (widget-get widget :args))
	(completion-ignore-case (widget-get widget :case-fold))
	current choices old)
    ;; Find the first arg that match VALUE.
    (let ((look args))
      (while look
	(if (widget-apply (car look) :match value)
	    (setq old (car look)
		  look nil)
	  (setq look (cdr look)))))
    ;; Find new choice.
    (setq current
	  (cond ((= (length args) 0)
		 nil)
		((= (length args) 1)
		 (nth 0 args))
		((and (= (length args) 2)
		      (memq old args))
		 (if (eq old (nth 0 args))
		     (nth 1 args)
		   (nth 0 args)))
		(t
		 (while args
		   (setq current (car args)
			 args (cdr args))
		   (setq choices
			 (cons (cons (widget-apply current :menu-tag-get)
				     current)
			       choices)))
		 (let ((val (completing-read prompt choices nil t)))
		   (if (stringp val)
		       (let ((try (try-completion val choices)))
			 (when (stringp try)
			   (setq val try))
			 (cdr (assoc val choices)))
		     nil)))))
    (if current
	(widget-prompt-value current prompt nil t)
      value)))

(define-widget 'radio 'radio-button-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}:\n%v"
  :prompt-value 'widget-choice-prompt-value)

(define-widget 'repeat 'editable-list
  "A variable length homogeneous list."
  :tag "Repeat"
  :format "%{%t%}:\n%v%i\n")

(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.
  (y-or-n-p prompt))

;;; The `color' Widget.

(define-widget 'color-item 'choice-item
  "A color name (with sample)."