Mercurial > emacs

changeset 19022:904dcdbb8576

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Synched with 1.9951.
author Per Abrahamsen <abraham@dina.kvl.dk>
date Mon, 28 Jul 1997 15:46:57 +0000
parents 6f150e46a5fd
children f7a3c16c49cb
files lisp/cus-edit.el lisp/wid-edit.el
diffstat 2 files changed, 201 insertions(+), 154 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/cus-edit.el	Mon Jul 28 15:10:21 1997 +0000
+++ b/lisp/cus-edit.el	Mon Jul 28 15:46:57 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: help, faces
-;; Version: 1.9944
+;; Version: 1.9951
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;; This file is part of GNU Emacs.
@@ -774,6 +774,26 @@
   (put var 'customized-value (list (custom-quote val))))
 
 ;;;###autoload
+(defun customize-save-variable (var val)
+  "Set the default for VARIABLE to VALUE, and save it for future sessions.
+If VARIABLE has a `custom-set' property, that is used for setting
+VARIABLE, otherwise `set-default' is used.
+
+The `customized-value' property of the VARIABLE will be set to a list
+with a quoted VALUE as its sole list member.
+
+If VARIABLE has a `variable-interactive' property, that is used as if
+it were the arg to `interactive' (which see) to interactively read the value.
+
+If VARIABLE has a `custom-type' property, it must be a widget and the
+`:prompt-value' property of that widget will be used for reading the value. " 
+  (interactive (custom-prompt-variable "Set and ave variable: "
+				       "Set and save value for %s as: "))
+  (funcall (or (get var 'custom-set) 'set-default) var val)
+  (put var 'saved-value (list (custom-quote val)))
+  (custom-save-all))
+
+;;;###autoload
 (defun customize ()
   "Select a customization buffer which you can use to set user options.
 User options are structured into \"groups\".
@@ -1109,6 +1129,7 @@
 		      options))))
   (unless (eq (preceding-char) ?\n)
     (widget-insert "\n"))
+  (message "Creating customization items %2d%%...done" 100)
   (unless (eq custom-buffer-style 'tree)
     (mapcar 'custom-magic-reset custom-options))
   (message "Creating customization setup...")
@@ -1119,45 +1140,46 @@
 ;;; The Tree Browser.
 
 ;;;###autoload
-(defun customize-browse ()
+(defun customize-browse (&optional group)
   "Create a tree browser for the customize hierarchy."
   (interactive)
-  (let ((group 'emacs))
-    (let ((name "*Customize Browser*"))
-      (kill-buffer (get-buffer-create name))
-      (switch-to-buffer (get-buffer-create name)))
-    (custom-mode)
-    (widget-insert "\
+  (unless group
+    (setq group 'emacs))
+  (let ((name "*Customize Browser*"))
+    (kill-buffer (get-buffer-create name))
+    (switch-to-buffer (get-buffer-create name)))
+  (custom-mode)
+  (widget-insert "\
 Square brackets show active fields; type RET or click mouse-1
 on an active field to invoke its action.
 Invoke [+] below to expand a group, and [-] to collapse an expanded group.\n")
-    (if custom-browse-only-groups
-	(widget-insert "\
+  (if custom-browse-only-groups
+      (widget-insert "\
 Invoke the [Group] button below to edit that item in another window.\n\n")
-      (widget-insert "Invoke the ") 
-      (widget-create 'item 
-		     :format "%t"
-		     :tag "[Group]"
-		     :tag-glyph "folder")
-      (widget-insert ", ")
-      (widget-create 'item 
-		     :format "%t"
-		     :tag "[Face]"
-		     :tag-glyph "face")
-      (widget-insert ", and ")
-      (widget-create 'item 
-		     :format "%t"
-		     :tag "[Option]"
-		     :tag-glyph "option")
-      (widget-insert " buttons below to edit that
+    (widget-insert "Invoke the ") 
+    (widget-create 'item 
+		   :format "%t"
+		   :tag "[Group]"
+		   :tag-glyph "folder")
+    (widget-insert ", ")
+    (widget-create 'item 
+		   :format "%t"
+		   :tag "[Face]"
+		   :tag-glyph "face")
+    (widget-insert ", and ")
+    (widget-create 'item 
+		   :format "%t"
+		   :tag "[Option]"
+		   :tag-glyph "option")
+    (widget-insert " buttons below to edit that
 item in another window.\n\n"))
-    (let ((custom-buffer-style 'tree))
-      (widget-create 'custom-group 
-		     :custom-last t
-		     :custom-state 'unknown
-		     :tag (custom-unlispify-tag-name group)
-		     :value group))
-    (goto-char (point-min))))
+  (let ((custom-buffer-style 'tree))
+    (widget-create 'custom-group 
+		   :custom-last t
+		   :custom-state 'unknown
+		   :tag (custom-unlispify-tag-name group)
+		   :value group))
+  (goto-char (point-min)))
 
 (define-widget 'custom-browse-visibility 'item
   "Control visibility of of items in the customize tree browser."
@@ -2549,19 +2571,32 @@
 	(insert "--------")))
   (widget-default-create widget))
 
+(defun custom-group-members (symbol groups-only)
+  "Return SYMBOL's custom group members.
+If GROUPS-ONLY non-nil, return only those members that are groups."
+  (if (not groups-only)
+      (get symbol 'custom-group)
+    (let (members)
+      (dolist (entry (get symbol 'custom-group))
+	(when (eq (nth 1 entry) 'custom-group)
+	  (push entry members)))
+      (nreverse members))))
+
 (defun custom-group-value-create (widget)
   "Insert a customize group for WIDGET in the current buffer."
-  (let ((state (widget-get widget :custom-state))
-	(level (widget-get widget :custom-level))
-	(indent (widget-get widget :indent))
-	(prefix (widget-get widget :custom-prefix))
-	(buttons (widget-get widget :buttons))
-	(tag (widget-get widget :tag))
-	(symbol (widget-value widget)))
+  (let* ((state (widget-get widget :custom-state))
+	 (level (widget-get widget :custom-level))
+	 (indent (widget-get widget :indent))
+	 (prefix (widget-get widget :custom-prefix))
+	 (buttons (widget-get widget :buttons))
+	 (tag (widget-get widget :tag))
+	 (symbol (widget-value widget))
+	 (members (custom-group-members symbol
+					(and (eq custom-buffer-style 'tree)
+					     custom-browse-only-groups))))
     (cond ((and (eq custom-buffer-style 'tree)
 		(eq state 'hidden)
-		(or (get symbol 'custom-group)
-		    (custom-unloaded-widget-p widget)))
+		(or members (custom-unloaded-widget-p widget)))
 	   (custom-browse-insert-prefix prefix)
 	   (push (widget-create-child-and-convert
 		  widget 'custom-browse-visibility 
@@ -2576,7 +2611,7 @@
 	   (insert " " tag "\n")
 	   (widget-put widget :buttons buttons))
 	  ((and (eq custom-buffer-style 'tree)
-		(zerop (length (get symbol 'custom-group))))
+		(zerop (length members)))
 	   (custom-browse-insert-prefix prefix)
 	   (insert "[ ]-- ")
 	   ;; (widget-glyph-insert nil "[ ]" "empty")
@@ -2589,7 +2624,7 @@
 	  ((eq custom-buffer-style 'tree)
 	   (custom-browse-insert-prefix prefix)
 	   (custom-load-widget widget)
-	   (if (zerop (length (get symbol 'custom-group)))
+	   (if (zerop (length members))
 	       (progn 
 		 (custom-browse-insert-prefix prefix)
 		 (insert "[ ]-- ")
@@ -2613,7 +2648,7 @@
 	     (insert " " tag "\n")
 	     (widget-put widget :buttons buttons)
 	     (message "Creating group...")
-	     (let* ((members (custom-sort-items (get symbol 'custom-group)
+	     (let* ((members (custom-sort-items members
 			      custom-browse-sort-alphabetically
 			      custom-browse-order-groups))
 		    (prefixes (widget-get widget :custom-prefixes))
@@ -2626,18 +2661,16 @@
 	       (while members
 		 (setq entry (car members)
 		       members (cdr members))
-		 (when (or (not custom-browse-only-groups)
-			   (eq (nth 1 entry) 'custom-group))
-		   (push (widget-create-child-and-convert
-			  widget (nth 1 entry)
-			  :group widget
-			  :tag (custom-unlispify-tag-name (nth 0 entry))
-			  :custom-prefixes custom-prefix-list
-			  :custom-level (1+ level)
-			  :custom-last (null members)
-			  :value (nth 0 entry)
-			  :custom-prefix prefix)
-			 children)))
+		 (push (widget-create-child-and-convert
+			widget (nth 1 entry)
+			:group widget
+			:tag (custom-unlispify-tag-name (nth 0 entry))
+			:custom-prefixes custom-prefix-list
+			:custom-level (1+ level)
+			:custom-last (null members)
+			:value (nth 0 entry)
+			:custom-prefix prefix)
+		       children))
 	       (widget-put widget :children (reverse children)))
 	     (message "Creating group...done")))
 	  ;; Nested style.
@@ -2732,7 +2765,7 @@
 	   ;; Members.
 	   (message "Creating group...")
 	   (custom-load-widget widget)
-	   (let* ((members (custom-sort-items (get symbol 'custom-group)
+	   (let* ((members (custom-sort-items members
 					      custom-buffer-sort-alphabetically
 					      custom-buffer-order-groups))
 		  (prefixes (widget-get widget :custom-prefixes))
@@ -2870,8 +2903,11 @@
 
 ;;; The `custom-save-all' Function.
 ;;;###autoload
-(defcustom custom-file (if (featurep 'xemacs)
-			   "~/.xemacs-custom"
+(defcustom custom-file (if (boundp 'emacs-user-extension-dir)
+			   (concat "~"
+				   init-file-user
+				   emacs-user-extension-dir
+				   "options.el")
 			 "~/.emacs")
   "File used for storing customization information.
 If you change this from the default \"~/.emacs\" you need to
@@ -2985,11 +3021,12 @@
 ;;;###autoload
 (defun custom-save-all ()
   "Save all customizations in `custom-file'."
-  (custom-save-variables)
-  (custom-save-faces)
-  (save-excursion
-    (set-buffer (find-file-noselect custom-file))
-    (save-buffer)))
+  (let ((inhibit-read-only t))
+    (custom-save-variables)
+    (custom-save-faces)
+    (save-excursion
+      (set-buffer (find-file-noselect custom-file))
+      (save-buffer))))
 
 ;;; The Customize Menu.
 
@@ -3148,6 +3185,9 @@
 
 Move to next button or editable field.     \\[widget-forward]
 Move to previous button or editable field. \\[widget-backward]
+\\<widget-field-keymap>\
+Complete content of editable text field.   \\[widget-complete]
+\\<custom-mode-map>\
 Invoke button under the mouse pointer.     \\[Custom-move-and-invoke]
 Invoke button under point.		   \\[widget-button-press]
 Set all modifications.			   \\[Custom-set]
--- a/lisp/wid-edit.el	Mon Jul 28 15:10:21 1997 +0000
+++ b/lisp/wid-edit.el	Mon Jul 28 15:46:57 1997 +0000
@@ -4,7 +4,7 @@
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.9945
+;; Version: 1.9951
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 
 ;; This file is part of GNU Emacs.
@@ -38,6 +38,7 @@
 (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
@@ -101,27 +102,6 @@
 	(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
@@ -352,18 +332,6 @@
 ;; 
 ;; 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)
@@ -378,9 +346,9 @@
   :group 'widgets)
 
 (defcustom widget-field-use-before-change
-  (or (> emacs-minor-version 34)
-      (>= emacs-major-version 20)
-      (string-match "XEmacs" emacs-version))
+  (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
@@ -390,7 +358,6 @@
 
 (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.
@@ -401,14 +368,6 @@
 	  (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))
@@ -461,8 +420,10 @@
 
 (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.
@@ -474,7 +435,6 @@
 	   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)))
@@ -887,8 +847,7 @@
 	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
@@ -902,7 +861,6 @@
   (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)
@@ -925,6 +883,7 @@
 	(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)
@@ -933,6 +892,8 @@
       (delete-overlay button))
     (when sample
       (delete-overlay sample))
+    (when doc
+      (delete-overlay doc))
     (when field
       (delete-overlay field))
     (mapcar 'widget-leave-text children)))
@@ -1126,6 +1087,12 @@
 	    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."
@@ -1136,9 +1103,12 @@
 	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"))
@@ -1149,9 +1119,12 @@
 	    (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"))
@@ -1187,7 +1160,9 @@
 	 (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."
@@ -1196,7 +1171,9 @@
 	 (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."
@@ -1250,14 +1227,7 @@
 	(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))))
+  (widget-add-change))
 
 (defvar widget-field-last nil)
 ;; Last field containing point.
@@ -1302,13 +1272,29 @@
 	  (setq found field))))
     found))
 
-(defun widget-before-change (from &rest ignore)
+(defun widget-before-change (from to)
   ;; 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"))))
+  (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.
@@ -1504,7 +1490,6 @@
        (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)
@@ -1570,6 +1555,7 @@
 	(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))
@@ -1580,6 +1566,8 @@
       (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))
@@ -1822,6 +1810,16 @@
   "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
@@ -2609,8 +2607,6 @@
 	(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))
@@ -2684,7 +2680,6 @@
 				      (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)
@@ -2943,7 +2938,8 @@
   "A regular expression."
   :match 'widget-regexp-match
   :validate 'widget-regexp-validate
-  :value-face 'widget-single-line-field-face
+  ;; Doesn't work well with terminating newline.
+  ;; :value-face 'widget-single-line-field-face
   :tag "Regexp")
 
 (defun widget-regexp-match (widget value)
@@ -2969,7 +2965,8 @@
   :complete-function 'widget-file-complete
   :prompt-value 'widget-file-prompt-value
   :format "%{%t%}: %v"
-  :value-face 'widget-single-line-field-face
+  ;; Doesn't work well with terminating newline.
+  ;; :value-face 'widget-single-line-field-face
   :tag "File")
 
 (defun widget-file-complete ()
@@ -3386,11 +3383,14 @@
 	   (message "Making completion list...done")))))
 
 (defun widget-color-sample-face-get (widget)
-  (let ((symbol (intern (concat "fg:" (widget-value 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)))))
@@ -3414,14 +3414,21 @@
   ;; 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)