Download
(require 'hexrgb)
(defvar eyedrop-picked-background nil
"Color last picked from a face or frame background.
You can use `eyedrop-pick-background-at-point' or
`eyedrop-pick-background-at-mouse' to pick the color.")
(defvar eyedrop-picked-foreground nil
"Color last picked from a face or frame foreground.
You can use `eyedrop-pick-foreground-at-point' or
`eyedrop-pick-foreground-at-mouse' to pick the color.")
(defvar eyedrop-last-picked-color nil
"Color last picked from a face or frame foreground or background.")
(unless (fboundp 'keywordp)
(defun keywordp (object)
"Return t if OBJECT is a keyword.
This means that it is a symbol with a print name beginning with `:'
interned in the initial obarray."
(and (symbolp object) (string-match "^:" (symbol-name object)) t)))
(defun eyedrop-color-message (color)
"Display information about COLOR as a message."
(let* ((rgb (hexrgb-hex-to-rgb color))
(hsv (apply #'hexrgb-rgb-to-hsv rgb)))
(message (format "Color: %s, RGB: %s, HSV: %s" color rgb hsv)))
color)
(defun eyedrop-background-at-mouse (event &optional msg-p)
"Return the background color under the mouse pointer.
Non-nil optional arg MSG-P means display an informative message."
(interactive "e\np")
(while (input-pending-p) (discard-input))
(when (and (consp event) (eq (event-basic-type (car event)) 'switch-frame))
(setq event (read-event)))
(set-buffer (window-buffer (posn-window (event-end event))))
(mouse-set-point event)
(let ((bg (eyedrop-background-at-point)))
(when msg-p (if bg (eyedrop-color-message bg) (message "No background color here")))
bg))
(defun eyedrop-foreground-at-mouse (event &optional msg-p)
"Return the foreground color under the mouse pointer.
Non-nil optional arg MSG-P means display an informative message."
(interactive "e\np")
(while (input-pending-p) (discard-input))
(when (and (consp event) (eq (event-basic-type (car event)) 'switch-frame))
(setq event (read-event)))
(set-buffer (window-buffer (posn-window (event-end event))))
(mouse-set-point event)
(let ((fg (eyedrop-foreground-at-point)))
(when msg-p (if fg (eyedrop-color-message fg) (message "No foreground color here")))
fg))
(defun eyedrop-face-at-point ()
"Return the face under the text cursor.
If there is more than one face, return the first one.
Return nil if there is no face at point."
(let* ((faceprop (or (get-char-property (point) 'read-face-name)
(get-char-property (point) 'face)
'default))
(face (cond ((symbolp faceprop) faceprop)
((and (consp faceprop) (not (keywordp (car faceprop)))
(not (memq (car faceprop) '(foreground-color background-color))))
(car faceprop))
(t nil))))
(if (facep face) face nil)))
(defalias 'background-color 'eyedrop-background-at-point)
(defun eyedrop-background-at-point (&optional msg-p)
"Return the background color under the text cursor.
Non-nil optional arg MSG-P means display an informative message."
(interactive "p")
(let* ((face (or (eyedrop-face-at-point)
(get-char-property (point) 'read-face-name)
(get-char-property (point) 'face)))
(bg (cond ((and face (symbolp face))
(condition-case nil
(face-background face nil 'default)
(error (or (face-background face)
(cdr (assq 'background-color (frame-parameters)))))))
((consp face)
(cond ((memq 'background-color face) (cdr (memq 'background-color face)))
((memq ':background face) (cadr (memq ':background face)))))
(t nil))))
(when msg-p
(if bg (eyedrop-color-message bg) (message "No background color here")))
bg))
(defalias 'foreground-color 'eyedrop-foreground-at-point)
(defun eyedrop-foreground-at-point (&optional msg-p)
"Return the foreground color under the text cursor.
Non-nil optional arg MSG-P means display an informative message."
(interactive "p")
(let* ((face (or (eyedrop-face-at-point)
(get-char-property (point) 'read-face-name)
(get-char-property (point) 'face)))
(fg (cond ((and face (symbolp face))
(condition-case nil
(face-foreground face nil 'default)
(error (or (face-foreground face)
(cdr (assq 'foreground-color (frame-parameters)))))))
((consp face)
(cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face)))
((memq ':foreground face) (cadr (memq ':foreground face)))))
(t nil))))
(when msg-p
(if fg (eyedrop-color-message fg) (message "No foreground color here")))
fg))
(defun eyedrop-pick-background-at-mouse (event &optional msg-p)
"Pick background of face or frame at character under the mouse pointer.
Save the background color in `eyedrop-picked-background' and
`eyedrop-last-picked-color'. Return the picked color.
Non-nil optional arg MSG-P means display an informative message."
(interactive "e\np")
(setq eyedrop-picked-background (eyedrop-background-at-mouse event)
eyedrop-last-picked-color eyedrop-picked-background)
(unless (stringp eyedrop-picked-background) (error "No background color here to pick"))
(when msg-p (eyedrop-color-message eyedrop-picked-background))
eyedrop-picked-background)
(defun eyedrop-pick-foreground-at-mouse (event &optional msg-p)
"Pick foreground of face or frame at character under the mouse pointer.
Save the foreground color in `eyedrop-picked-foreground' and
`eyedrop-last-picked-color'. Return the picked color.
Non-nil optional arg MSG-P means display an informative message."
(interactive "e\np")
(setq eyedrop-picked-foreground (eyedrop-foreground-at-mouse event)
eyedrop-last-picked-color eyedrop-picked-foreground)
(unless (stringp eyedrop-picked-foreground) (error "No foreground color here to pick"))
(when msg-p (eyedrop-color-message eyedrop-picked-foreground))
eyedrop-picked-foreground)
(defalias 'eyedropper-background 'eyedrop-pick-background-at-point)
(defalias 'pick-background-color 'eyedrop-pick-background-at-point)
(defun eyedrop-pick-background-at-point (&optional msg-p)
"Pick background of face or frame at character at text cursor (point).
Save the background color in `eyedrop-picked-background' and
`eyedrop-last-picked-color'. Return the picked color.
Non-nil optional arg MSG-P means display an informative message."
(interactive "p")
(setq eyedrop-picked-background (eyedrop-background-at-point)
eyedrop-last-picked-color eyedrop-picked-background)
(unless (stringp eyedrop-picked-background) (error "No background color here to pick"))
(when msg-p (eyedrop-color-message eyedrop-picked-background))
eyedrop-picked-background)
(defalias 'eyedropper-foreground 'eyedrop-pick-foreground-at-point)
(defalias 'pick-foreground-color 'eyedrop-pick-foreground-at-point)
(defun eyedrop-pick-foreground-at-point (&optional msg-p)
"Pick foreground of face or frame at character at text cursor (point).
Save the foreground color in `eyedrop-picked-foreground' and
`eyedrop-last-picked-color'. Return the picked color.
Non-nil optional arg MSG-P means display an informative message."
(interactive "p")
(setq eyedrop-picked-foreground (eyedrop-foreground-at-point)
eyedrop-last-picked-color eyedrop-picked-foreground)
(unless (stringp eyedrop-picked-foreground) (error "No foreground color here to pick"))
(when msg-p (eyedrop-color-message eyedrop-picked-foreground))
eyedrop-picked-foreground)
(provide 'eyedropper)