;; 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))))
(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.
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Background mode.
projects / emacs.git / commitdiff