comparison lisp/wid-edit.el @ 19022:904dcdbb8576

Synched with 1.9951.

19021:6f150e46a5fd

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

;;; Compatibility.

(eval-and-compile
  (autoload 'pp-to-string "pp")
  (autoload 'Info-goto-node "info")

  (when (string-match "XEmacs" emacs-version)
    (condition-case nil
	(require 'overlay)
      (error (load-library "x-overlay"))))

      "Convert an error value to an error message."
      (let ((buf (get-buffer-create " *error-message*")))
	(erase-buffer buf)
	(display-error obj buf)
	(buffer-string buf)))))

(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
  "Customization support for the Widget Library."

;;; Widget text specifications.
;; 
;; 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)
	   (< emacs-minor-version 3))
      (not (string-match "XEmacs" emacs-version)))

size field."
  :type 'boolean
  :group 'widgets)

(defcustom widget-field-use-before-change
  (or (> emacs-minor-version 34)
      (>= emacs-major-version 20)
      (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)
    (cond ((null (widget-get widget :size))
	   (forward-char 1))
	  (widget-field-add-space
	   (insert-and-inherit " ")))
    (setq to (point)))
  (if (or widget-field-add-space
	  (null (widget-get widget :size)))
      (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 (or (not widget-field-add-space)

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

(defmacro widget-specify-insert (&rest form)
  ;; Execute FORM without inheriting any text properties.
  (`
   (save-restriction

	   result
	   before-change-functions
	   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)))
       (delete-region (1- (point-max)) (point-max))
       (goto-char (point-max))

  "Call `insert' with ARGS and make the text read only."
  (let ((inhibit-read-only t)
	before-change-functions
	after-change-functions
	(from (point)))
    (apply 'insert args)
    (widget-specify-text from (point))))

(defun widget-convert-text (type from to
				 &optional button-from button-to
				 &rest args)
  "Return a widget of type TYPE with endpoint FROM TO.

button end points.
Optional ARGS are extra keyword arguments for TYPE."
  (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)
    (widget-put widget :to to)
    (when button-from

  "Remove markers and overlays from WIDGET and its children."
  (let ((from (widget-get widget :from))
	(to (widget-get widget :to))
	(button (widget-get widget :button-overlay))
	(sample (widget-get widget :sample-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 field
      (delete-overlay field))
    (mapcar 'widget-leave-text children)))

;;; Keymap and Commands.

		  widget
		nil)
	    widget))
      nil)))

(defun widget-move (arg)
  "Move point to the ARG next field or button.
ARG may be negative to move backward."
  (or (bobp) (> arg 0) (backward-char))
  (let ((pos (point))
	(number arg)
	(old (widget-tabable-at))
	new)
    ;; Forward.
    (while (> arg 0)
      (if (eobp)
	  (goto-char (point-min))
	(forward-char 1))
      (and (eq pos (point))
	   (eq arg number)
	   (error "No buttons or fields found"))
      (let ((new (widget-tabable-at)))
	(when new
	  (unless (eq new old)
	    (setq arg (1- arg))
	    (setq old new)))))
    ;; Backward.
    (while (< arg 0)
      (if (bobp)
	  (goto-char (point-max))
	(backward-char 1))
      (and (eq pos (point))
	   (eq arg number)
	   (error "No buttons or fields found"))
      (let ((new (widget-tabable-at)))
	(when new

  (interactive)
  (let* ((field (widget-field-find (point)))
	 (start (and field (widget-field-start field))))
    (if (and start (not (eq start (point))))
	(goto-char start)
      (call-interactively 'beginning-of-line))))

(defun widget-end-of-line ()
  "Go to end of field or end of line, whichever is first."
  (interactive)
  (let* ((field (widget-field-find (point)))
	 (end (and field (widget-field-end field))))
    (if (and end (not (eq end (point))))
	(goto-char end)
      (call-interactively 'end-of-line))))

(defun widget-kill-line ()
  "Kill to end of field or end of line, whichever is first."
  (interactive)
  (let* ((field (widget-field-find (point)))

	(widget-specify-field field 
			      (marker-position from) (marker-position to))
	(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)
  (setq after-change-functions
	(if widget-field-list '(widget-after-change) nil))
  (when widget-field-use-before-change
    (make-local-variable 'before-change-functions)
    (setq before-change-functions
	  (if widget-field-list '(widget-before-change) nil))))

(defvar widget-field-last nil)
;; Last field containing point.
(make-variable-buffer-local 'widget-field-last)

	  (when found
	    (debug "Overlapping fields"))
	  (setq found field))))
    found))

(defun widget-before-change (from &rest ignore)
  ;; This is how, for example, a variable changes its state to `modified'.
  ;; when it is being edited.
  (condition-case nil
      (let ((field (widget-field-find from)))
	(widget-apply field :notify field))
    (error (debug "Before Change"))))

(defun widget-after-change (from to old)
  ;; Adjust field size and text properties.
  (condition-case nil
      (let ((field (widget-field-find from))

     (when value-pos
       (goto-char value-pos)
       (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)
     (widget-put widget :to to)))
  (widget-clear-undo))

  (let ((from (widget-get widget :from))
	(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))
	before-change-functions
	after-change-functions
	(inhibit-read-only t))
    (widget-apply widget :value-delete)
    (when inactive-overlay
      (delete-overlay inactive-overlay))
    (when button-overlay
      (delete-overlay button-overlay))
    (when sample-overlay
      (delete-overlay sample-overlay))
    (when (< from to)
      ;; Kludge: this doesn't need to be true for empty formats.
      (delete-region from to))
    (set-marker from nil)
    (set-marker to nil))

  :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 `editable-field' Widget.

(define-widget 'editable-field 'default
  "An editable text field."

      (let ((child (widget-editable-list-entry-create 
		    widget nil nil)))
	(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))
	    (setq children (cdr children)))
	  (setcdr children (cons child (cdr children)))))))

		 :buttons (cons delete 
				(cons insert
				      (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-put child :entry-to entry-to)))
    (widget-put insert :widget child)

(define-widget 'regexp 'string
  "A regular expression."
  :match 'widget-regexp-match
  :validate 'widget-regexp-validate
  :value-face 'widget-single-line-field-face
  :tag "Regexp")

(defun widget-regexp-match (widget value)
  ;; Match valid regexps.
  (and (stringp value)

  "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"
  :value-face 'widget-single-line-field-face
  :tag "File")

(defun widget-file-complete ()
  "Perform completion on file name preceding point."
  (interactive)

	     (with-output-to-temp-buffer "*Completions*"
	       (display-completion-list list)))
	   (message "Making completion list...done")))))

(defun widget-color-sample-face-get (widget)
  (let ((symbol (intern (concat "fg:" (widget-value widget)))))
    (if (string-match "XEmacs" emacs-version)
	(prog1 symbol
	  (or (find-face symbol)
	      (set-face-foreground (make-face symbol) (widget-value widget))))
      (condition-case nil
	  (facemenu-get-face symbol)
	(error 'default)))))

(defvar widget-color-choice-list nil)

(defun widget-color-action (widget &optional event)
  ;; 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))))))
    (unless (zerop (length answer))
      (widget-value-set widget answer)
      (widget-setup)
      (widget-apply widget :notify widget event))))

19022:904dcdbb8576

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

;;; Compatibility.

(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
	(require 'overlay)
      (error (load-library "x-overlay"))))

      "Convert an error value to an error message."
      (let ((buf (get-buffer-create " *error-message*")))
	(erase-buffer buf)
	(display-error obj buf)
	(buffer-string buf)))))

;;; Customization.

(defgroup widgets nil
  "Customization support for the Widget Library."

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

(defcustom widget-field-add-space 
  (or (< emacs-major-version 20)
      (and (eq emacs-major-version 20)
	   (< emacs-minor-version 3))
      (not (string-match "XEmacs" emacs-version)))

size field."
  :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."
  ;; 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)
    (cond ((null (widget-get widget :size))
	   (forward-char 1))
	  (widget-field-add-space
	   (insert-and-inherit " ")))
    (setq to (point)))
  (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 (or (not widget-field-add-space)

    (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.
  (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.
  (`
   (save-restriction

	   result
	   before-change-functions
	   after-change-functions)
       (insert "<>")
       (narrow-to-region (- (point) 2) (point))
       (goto-char (1+ (point-min)))
       (setq result (progn (,@ form)))
       (delete-region (point-min) (1+ (point-min)))
       (delete-region (1- (point-max)) (point-max))
       (goto-char (point-max))

  "Call `insert' with ARGS and make the text read only."
  (let ((inhibit-read-only t)
	before-change-functions
	after-change-functions
	(from (point)))
    (apply 'insert args)))

(defun widget-convert-text (type from to
				 &optional button-from button-to
				 &rest args)
  "Return a widget of type TYPE with endpoint FROM TO.

button end points.
Optional ARGS are extra keyword arguments for TYPE."
  (let ((widget (apply 'widget-convert type :delete 'widget-leave-text args))
	(from (copy-marker from))
	(to (copy-marker to)))
    (set-marker-insertion-type from t)
    (set-marker-insertion-type to nil)
    (widget-put widget :from from)
    (widget-put widget :to to)
    (when button-from

  "Remove markers and overlays from WIDGET and its children."
  (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)))

;;; Keymap and Commands.

		  widget
		nil)
	    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."
  (or (bobp) (> arg 0) (backward-char))
  (let ((pos (point))
	(number arg)
	(old (widget-tabable-at))
	new)
    ;; Forward.
    (while (> arg 0)
      (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"))
      (let ((new (widget-tabable-at)))
	(when new
	  (unless (eq new old)
	    (setq arg (1- arg))
	    (setq old new)))))
    ;; Backward.
    (while (< arg 0)
      (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"))
      (let ((new (widget-tabable-at)))
	(when new

  (interactive)
  (let* ((field (widget-field-find (point)))
	 (start (and field (widget-field-start field))))
    (if (and start (not (eq start (point))))
	(goto-char start)
      (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."
  (interactive)
  (let* ((field (widget-field-find (point)))
	 (end (and field (widget-field-end field))))
    (if (and end (not (eq end (point))))
	(goto-char end)
      (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."
  (interactive)
  (let* ((field (widget-field-find (point)))

	(widget-specify-field field 
			      (marker-position from) (marker-position to))
	(set-marker from nil)
	(set-marker to nil))))
  (widget-clear-undo)
  (widget-add-change))

(defvar widget-field-last nil)
;; Last field containing point.
(make-variable-buffer-local 'widget-field-last)

	  (when found
	    (debug "Overlapping fields"))
	  (setq found field))))
    found))

(defun widget-before-change (from to)
  ;; This is how, for example, a variable changes its state to `modified'.
  ;; when it is being edited.
  (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.
  (condition-case nil
      (let ((field (widget-field-find from))

     (when value-pos
       (goto-char value-pos)
       (widget-apply widget :value-create)))
   (let ((from (copy-marker (point-min)))
	 (to (copy-marker (point-max))))
     (set-marker-insertion-type from t)
     (set-marker-insertion-type to nil)
     (widget-put widget :from from)
     (widget-put widget :to to)))
  (widget-clear-undo))

  (let ((from (widget-get widget :from))
	(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))
    (widget-apply widget :value-delete)
    (when inactive-overlay
      (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))
    (set-marker from nil)
    (set-marker to nil))

  :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
  "An editable text field."

      (let ((child (widget-editable-list-entry-create 
		    widget nil nil)))
	(when (< (widget-get child :entry-from) (widget-get widget :from))
	  (set-marker (widget-get widget :from)
		      (widget-get child :entry-from)))
	(if (eq (car children) before)
	    (widget-put widget :children (cons child children))
	  (while (not (eq (car (cdr children)) before))
	    (setq children (cdr children)))
	  (setcdr children (cons child (cdr children)))))))

		 :buttons (cons delete 
				(cons insert
				      (widget-get widget :buttons))))
     (let ((entry-from (copy-marker (point-min)))
	   (entry-to (copy-marker (point-max))))
       (set-marker-insertion-type entry-from t)
       (set-marker-insertion-type entry-to nil)
       (widget-put child :entry-from entry-from)
       (widget-put child :entry-to entry-to)))
    (widget-put insert :widget child)

(define-widget 'regexp 'string
  "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)
  ;; Match valid regexps.
  (and (stringp value)

  "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"
  ;; 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)

	     (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) value)))
      (condition-case nil
	  (facemenu-get-face symbol)
	(error 'default)))))

(defvar widget-color-choice-list nil)

(defun widget-color-action (widget &optional event)
  ;; Prompt for a color.
  (let* ((tag (widget-apply widget :menu-tag-get))
	 (prompt (concat tag ": "))
	 (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))))