changeset 107382:96ec3562df8f

Allow using list-colors-display to set colors in the Color widget. * facemenu.el (list-colors-display, list-colors-print): New arg callback. Use it to allow selecting colors. * wid-edit.el (widget-image-insert): Insert image prop even if the current display is non-graphic. (widget-field-value-set): New fun. (editable-field): Use it. (widget-field-value-get): Clean up unused var. (widget-color-value-create, widget-color--choose-action): New funs. Allow using list-colors-display to choose color.

--- a/lisp/ChangeLog	Fri Mar 12 17:56:30 2010 -0500
+++ b/lisp/ChangeLog	Fri Mar 12 18:08:30 2010 -0500
@@ -1,3 +1,16 @@
[phone]  Chong Yidong  <[e-mail]>
+
+	* facemenu.el (list-colors-display, list-colors-print): New arg
+	callback.  Use it to allow selecting colors.
+
+	* wid-edit.el (widget-image-insert): Insert image prop even if the
+	current display is non-graphic.
+	(widget-field-value-set): New fun.
+	(editable-field): Use it.
+	(widget-field-value-get): Clean up unused var.
+	(widget-color-value-create, widget-color--choose-action): New
+	funs.  Allow using list-colors-display to choose color.
+
 2010-03-12  Chong Yidong  <[e-mail]>
 
 	* cus-edit.el: Resort topmost custom groups.

--- a/lisp/facemenu.el	Fri Mar 12 17:56:30 2010 -0500
+++ b/lisp/facemenu.el	Fri Mar 12 18:08:30 2010 -0500
@@ -479,12 +479,20 @@
 	nil
       col)))
 
-(defun list-colors-display (&optional list buffer-name)
+
+(defun list-colors-display (&optional list buffer-name callback)
   "Display names of defined colors, and show what they look like.
 If the optional argument LIST is non-nil, it should be a list of
 colors to display.  Otherwise, this command computes a list of
-colors that the current display can handle.  If the optional
-argument BUFFER-NAME is nil, it defaults to *Colors*."
+colors that the current display can handle.
+
+If the optional argument BUFFER-NAME is nil, it defaults to
+*Colors*.
+
+If the optional argument CALLBACK is non-nil, it should be a
+function to call each time the user types RET or clicks on a
+color.  The function should accept a single argument, the color
+name."
   (interactive)
   (when (and (null list) (> (display-color-cells) 0))
     (setq list (list-colors-duplicates (defined-colors)))
@@ -493,49 +501,57 @@
       (let ((lc (nthcdr (1- (display-color-cells)) list)))
 	(if lc
 	    (setcdr lc nil)))))
-  (with-help-window (or buffer-name "*Colors*")
-    (with-current-buffer standard-output
+  (let ((buf (get-buffer-create "*Colors*")))
+    (with-current-buffer buf
+      (erase-buffer)
       (setq truncate-lines t)
-      (if temp-buffer-show-function
-	  (list-colors-print list)
-	;; Call list-colors-print from temp-buffer-show-hook
-	;; to get the right value of window-width in list-colors-print
-	;; after the buffer is displayed.
-	(add-hook 'temp-buffer-show-hook
-		  (lambda ()
-		    (set-buffer-modified-p
-		     (prog1 (buffer-modified-p)
-		       (list-colors-print list))))
-		  nil t)))))
+      (list-colors-print list callback)
+      (set-buffer-modified-p nil))
+    (pop-to-buffer buf))
+  (if callback
+      (message "Click on a color to select it.")))
 
-(defun list-colors-print (list)
-  (dolist (color list)
-    (if (consp color)
-	(if (cdr color)
-	    (setq color (sort color (lambda (a b)
-				      (string< (downcase a)
-					       (downcase b))))))
-      (setq color (list color)))
-    (put-text-property
-     (prog1 (point)
-       (insert (car color))
-       (indent-to 22))
-     (point)
-     'face (list ':background (car color)))
-    (put-text-property
-     (prog1 (point)
-       (insert " " (if (cdr color)
-		       (mapconcat 'identity (cdr color) ", ")
-		     (car color))))
-     (point)
-     'face (list ':foreground (car color)))
-    (indent-to (max (- (window-width) 8) 44))
-    (insert (apply 'format "#%02x%02x%02x"
-		   (mapcar (lambda (c) (lsh c -8))
-			   (color-values (car color)))))
+(defun list-colors-print (list &optional callback)
+  (let ((callback-fn
+	 (if callback
+	     `(lambda (button)
+		(funcall ,callback (button-get button 'color-name))))))
+    (dolist (color list)
+      (if (consp color)
+	  (if (cdr color)
+	      (setq color (sort color (lambda (a b)
+					(string< (downcase a)
+						 (downcase b))))))
+	(setq color (list color)))
+      (let* ((opoint (point))
+	     (color-values (color-values (car color)))
+	     (light-p (>= (apply 'max color-values)
+			  (* (car (color-values "white")) .5))))
+	(insert (car color))
+	(indent-to 22)
+	(put-text-property opoint (point) 'face `(:background ,(car color)))
+	(put-text-property
+	 (prog1 (point)
+	   (insert " " (if (cdr color)
+			   (mapconcat 'identity (cdr color) ", ")
+			 (car color))))
+	 (point)
+	 'face (list :foreground (car color)))
+	(indent-to (max (- (window-width) 8) 44))
+	(insert (apply 'format "#%02x%02x%02x"
+		       (mapcar (lambda (c) (lsh c -8))
+			       color-values)))
+	(when callback
+	  (make-text-button
+	   opoint (point)
+	   'follow-link t
+	   'mouse-face (list :background (car color)
+			     :foreground (if light-p "black" "white"))
+	   'color-name (car color)
+	   'action callback-fn)))
+      (insert "\n"))
+    (goto-char (point-min))))
 
-    (insert "\n"))
-  (goto-char (point-min)))
 
 (defun list-colors-duplicates (&optional list)
   "Return a list of colors with grouped duplicate colors.

--- a/lisp/wid-edit.el	Fri Mar 12 17:56:30 2010 -0500
+++ b/lisp/wid-edit.el	Fri Mar 12 18:08:30 2010 -0500
@@ -78,8 +78,7 @@
   :link '(custom-manual "(widget)Top")
   :link '(emacs-library-link :tag "Lisp File" "widget.el")
   :prefix "widget-"
-  :group 'extensions
-  :group 'hypermedia)
+  :group 'extensions)
 
 (defgroup widget-documentation nil
   "Options controlling the display of documentation strings."
@@ -656,7 +655,7 @@
 
 Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
 button is pressed or inactive, respectively.  These are currently ignored."
-  (if (and (display-graphic-p)
+  (if (and (featurep 'image)
 	   (setq image (widget-image-find image)))
       (progn (widget-put widget :suppress-face t)
 	     (insert-image image tag))
@@ -1873,6 +1872,7 @@
   :valid-regexp ""
   :error "Field's value doesn't match allowed forms"
   :value-create 'widget-field-value-create
+  :value-set 'widget-field-value-set
   :value-delete 'widget-field-value-delete
   :value-get 'widget-field-value-get
   :match 'widget-field-match)
@@ -1911,6 +1911,18 @@
 			(widget-apply widget :value-get))
     widget))
 
+(defun widget-field-value-set (widget value)
+  "Set an editable text field WIDGET to VALUE"
+  (let ((from (widget-field-start widget))
+	(to (widget-field-text-end widget))
+	(buffer (widget-field-buffer widget))
+	(size (widget-get widget :size)))
+    (when (and from to (buffer-live-p buffer))
+      (with-current-buffer buffer
+	(goto-char from)
+	(delete-char (- to from))
+	(insert value)))))
+
 (defun widget-field-value-create (widget)
   "Create an editable text field."
   (let ((size (widget-get widget :size))
@@ -1948,7 +1960,6 @@
   (let ((from (widget-field-start widget))
 	(to (widget-field-text-end widget))
 	(buffer (widget-field-buffer widget))
-	(size (widget-get widget :size))
 	(secret (widget-get widget :secret))
 	(old (current-buffer)))
     (if (and from to)
@@ -3695,6 +3706,7 @@
 (define-widget 'color 'editable-field
   "Choose a color name (with sample)."
   :format "%{%t%}: %v (%{sample%})\n"
+  :value-create 'widget-color-value-create
   :size 10
   :tag "Color"
   :value "black"
@@ -3703,6 +3715,27 @@
   :notify 'widget-color-notify
   :action 'widget-color-action)
 
+(defun widget-color-value-create (widget)
+  (widget-field-value-create widget)
+  (widget-insert " ")
+  (widget-create-child-and-convert
+   widget 'push-button
+   :tag "Choose" :action 'widget-color--choose-action)
+  (widget-insert " "))
+
+(defun widget-color--choose-action (widget &optional event)
+  (list-colors-display
+   nil nil
+   `(lambda (color)
+      (when (buffer-live-p ,(current-buffer))
+	(widget-value-set ',(widget-get widget :parent) color)
+	(let* ((buf (get-buffer "*Colors*"))
+	       (win (get-buffer-window buf 0)))
+	  (bury-buffer buf)
+	  (and win (> (length (window-list)) 1)
+	       (delete-window win)))
+	(pop-to-buffer ,(current-buffer))))))
+
 (defun widget-color-complete (widget)
   "Complete the color in WIDGET."
   (require 'facemenu)			; for facemenu-color-alist