(read-color): New function.

(face-at-point, foreground-color-at-point)
(background-color-at-point): New functions.

1 files changed, 140 insertions, 0 deletions

diff --git a/lisp/faces.el b/lisp/faces.el
index ab299160b6d..83b69ca630f 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1472,6 +1472,12 @@ See `defface' for information about SPEC.  If SPEC is nil, do nothing."
     ;; When we reset the face based on its spec, then it is unmodified
     ;; as far as Custom is concerned.
     (put (or (get face 'face-alias) face) 'face-modified nil)
+;;;     ;; Clear all the new-frame defaults for this face.
+;;;     ;; face-spec-reset-face won't do it right.
+;;;     (let ((facevec (cdr (assq face face-new-frame-defaults))))
+;;;       (dotimes (i (length facevec))
+;;;     (unless (= i 0)
+;;;       (aset facevec i 'unspecified))))
     ;; Set each frame according to the rules implied by SPEC.
     (dolist (frame (frame-list))
       (face-spec-set face spec frame))))
@@ -1598,6 +1604,140 @@ If omitted or nil, that stands for the selected frame's display."
      (t
       (> (tty-color-gray-shades display) 2)))))
 
+(defun read-color (&optional prompt convert-to-RGB-p allow-empty-name-p msg-p)
+  "Read a color name or RGB hex value: #RRRRGGGGBBBB.
+Completion is available for color names, but not for RGB hex strings.
+If the user inputs an RGB hex string, it must have the form
+#XXXXXXXXXXXX or XXXXXXXXXXXX, where each X is a hex digit.  The
+number of Xs must be a multiple of 3, with the same number of Xs for
+each of red, green, and blue.  The order is red, green, blue.
+
+In addition to standard color names and RGB hex values, the following
+are available as color candidates.  In each case, the corresponding
+color is used.
+
+ * `foreground at point'   - foreground under the cursor
+ * `background at point'   - background under the cursor
+
+Checks input to be sure it represents a valid color.  If not, raises
+an error (but see exception for empty input with non-nil
+ALLOW-EMPTY-NAME-P).
+
+Optional arg PROMPT is the prompt; if nil, uses a default prompt.
+
+Interactively, or with optional arg CONVERT-TO-RGB-P non-nil, converts
+an input color name to an RGB hex string.  Returns the RGB hex string.
+
+Optional arg ALLOW-EMPTY-NAME-P controls what happens if the user
+enters an empty color name (that is, just hits `RET').  If non-nil,
+then returns an empty color name, \"\".  If nil, then raises an error.
+Programs must test for \"\" if ALLOW-EMPTY-NAME-P is non-nil.  They
+can then perform an appropriate action in case of empty input.
+
+Interactively, or with optional arg MSG-P non-nil, echoes the color in
+a message."
+  (interactive "i\np\ni\np")    ; Always convert to RGB interactively.
+  (let* ((completion-ignore-case t)
+         (colors (append '("foreground at point" "background at point")
+                         (defined-colors)))
+         (color (completing-read (or prompt "Color (name or #R+G+B+): ")
+                                 colors))
+         hex-string)
+    (cond ((string= "foreground at point" color)
+           (setq color (foreground-color-at-point)))
+          ((string= "background at point" color)
+           (setq color (background-color-at-point))))
+    (unless color
+      (setq color ""))
+    (setq hex-string
+          (string-match "^#?\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color))
+    (if (and allow-empty-name-p (string= "" color))
+        ""
+      (when (and hex-string (not (eq (aref color 0) ?#)))
+        (setq color (concat "#" color))) ; No #; add it.
+      (unless hex-string
+        (when (or (string= "" color) (not (test-completion color colors)))
+          (error "No such color: %S" color))
+        (when convert-to-RGB-p
+          (let ((components (x-color-values color)))
+            (unless components (error "No such color: %S" color))
+            (unless (string-match "^#\\([a-fA-F0-9][a-fA-F0-9][a-fA-F0-9]\\)+$" color)
+              (setq color (format "#%04X%04X%04X"
+                                  (logand 65535 (nth 0 components))
+                                  (logand 65535 (nth 1 components))
+                                  (logand 65535 (nth 2 components))))))))
+      (when msg-p (message "Color: `%s'" color))
+      color)))
+
+;; Commented out because I decided it is better to include the
+;; duplicates in read-color's completion list.
+
+;; (defun defined-colors-without-duplicates ()
+;;   "Return the list of defined colors, without the no-space versions.
+;; For each color name, we keep the variant that DOES have spaces."
+;;   (let ((result (copy-sequence (defined-colors)))
+;;         to-be-rejected)
+;;     (save-match-data
+;;       (dolist (this result)
+;;         (if (string-match " " this)
+;;             (push (replace-regexp-in-string " " "" 
+;;                                             this)
+;;                   to-be-rejected)))
+;;       (dolist (elt to-be-rejected)
+;;         (let ((as-found (car (member-ignore-case elt result))))
+;;           (setq result (delete as-found result)))))
+;;     result))
+
+(defun face-at-point ()
+  "Return the face of the character after point.
+If it has more than one face, return the first one.
+Return nil if it has no specified face."
+  (let* ((faceprop (or (get-char-property (point) 'read-face-name)
+                       (get-char-property (point) 'face)
+                       'default))
+         (face (cond ((symbolp faceprop) faceprop)
+                     ;; List of faces (don't treat an attribute spec).
+                     ;; Just use the first face.
+                     ((and (consp faceprop) (not (keywordp (car faceprop)))
+                           (not (memq (car faceprop)
+                                      '(foreground-color background-color))))
+                      (car faceprop))
+                     (t nil))))         ; Invalid face value.
+    (if (facep face) face nil)))
+
+(defun foreground-color-at-point ()
+  "Return the foreground color of the character after point."
+  ;; `face-at-point' alone is not sufficient.  It only gets named faces.
+  ;; Need also pick up any face properties that are not associated with named faces.
+  (let ((face (or (face-at-point)
+                  (get-char-property (point) 'read-face-name)
+                  (get-char-property (point) 'face))))
+    (cond ((and face (symbolp face))
+           (let ((value (face-foreground face nil 'default)))
+             (if (member value '("unspecified-fg" "unspecified-bg"))
+                 nil
+               value)))
+          ((consp face)
+           (cond ((memq 'foreground-color face) (cdr (memq 'foreground-color face)))
+                 ((memq ':foreground face) (cadr (memq ':foreground face)))))
+          (t nil))))                    ; Invalid face value.
+
+(defun background-color-at-point ()
+  "Return the background color of the character after point."
+  ;; `face-at-point' alone is not sufficient.  It only gets named faces.
+  ;; Need also pick up any face properties that are not associated with named faces.
+  (let ((face (or (face-at-point)
+                  (get-char-property (point) 'read-face-name)
+                  (get-char-property (point) 'face))))
+    (cond ((and face (symbolp face))
+           (let ((value (face-background face nil 'default)))
+             (if (member value '("unspecified-fg" "unspecified-bg"))
+                 nil
+               value)))
+          ((consp face)
+           (cond ((memq 'background-color face) (cdr (memq 'background-color face)))
+                 ((memq ':background face) (cadr (memq ':background face)))))
+          (t nil))))                    ; Invalid face value.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Background mode.