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.
This commit is contained in:
Chong Yidong
parent
647f999385
commit
6f320937a4
3 changed files with 109 additions and 47 deletions
|
|
@ -1,3 +1,16 @@
|
|||
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.
|
||||
|
|
|
|||
102
lisp/facemenu.el
102
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)))))
|
||||
(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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue