Commit 6f320937 authored by Chong Yidong's avatar Chong Yidong

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.
parent 647f9993
2010-03-12 Chong Yidong <cyd@stupidchicken.com>
* 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 <cyd@stupidchicken.com>
* cus-edit.el: Resort topmost custom groups.
......
......@@ -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.
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment