From 6f320937a40f8905c2e72498c042423a1e7610a3 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 12 Mar 2010 18:08:30 -0500 Subject: [PATCH] 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. --- lisp/ChangeLog | 13 ++++++ lisp/facemenu.el | 106 +++++++++++++++++++++++++++-------------------- lisp/wid-edit.el | 41 ++++++++++++++++-- 3 files changed, 111 insertions(+), 49 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index edc66039633..5dc59f3cf1c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -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 --git a/lisp/facemenu.el b/lisp/facemenu.el index 6f9e6799763..b7c9f359095 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -479,12 +479,20 @@ These special properties include `invisible', `intangible' and `read-only'." 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 @@ argument BUFFER-NAME is nil, it defaults to *Colors*." (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))))) - -(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))))) - - (insert "\n")) - (goto-char (point-min))) + (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 &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)))) + (defun list-colors-duplicates (&optional list) "Return a list of colors with grouped duplicate colors. diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 7633de3a202..6296a965df9 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -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 @@ IMAGE should either be an image or an image file name sans extension 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 @@ by some other text in the `:format' string (if specified)." :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 @@ the earlier input." (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 @@ the earlier input." (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 @@ example: (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 @@ example: :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 -- 2.39.2