# HG changeset patch # User Chong Yidong # Date 1268435310 18000 # Node ID 96ec3562df8f79264822d8b2d293a01c267f486f # Parent c97f25cea7c40099ea97f899da02f91cf35e14a9 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. diff -r c97f25cea7c4 -r 96ec3562df8f lisp/ChangeLog --- 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 @@ +2010-03-12 Chong Yidong + + * 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 * cus-edit.el: Resort topmost custom groups. diff -r c97f25cea7c4 -r 96ec3562df8f lisp/facemenu.el --- 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. diff -r c97f25cea7c4 -r 96ec3562df8f lisp/wid-edit.el --- 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