3

I am writing a function to get the foreground color of the face at point and am thinking that Emacs may already provide a better method than the one I'm composing?

I am going to be using this function about 50 times every redisplay (i.e., once for every visible horizontal line, going down a column vertically from window-start to window-end), so I want it to be as efficient as possible.

With the proposed function get-face, I would use: (when (eq (car (text-properties-at (point))) 'face) (nth 23 (get-face (nth 1 (text-properties-at (point)))))).

I'm not certain under what circumstances more than one face will exist, or whether the car of text-properties-at will always contain the symbol face if a face is present?

I still have not dealt with handling an inherit situation.

(defun get-face (face)
"Doc-string."
  (let* (
      (attributes (face-all-attributes face (selected-frame)))
      (family-car (car (nth 0 attributes)))
      (family-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 0 attributes))))
          "Courier"
          (cdr (nth 0 attributes))))
      (foundry-car (car (nth 1 attributes)))
      (foundry-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 1 attributes))))
          nil
          (cdr (nth 1 attributes))))
      (width-car (car (nth 2 attributes)))
      (width-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 2 attributes))))
          'normal
          (cdr (nth 2 attributes))))
      (height-car (car (nth 3 attributes)))
      (height-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 3 attributes))))
          180
          (cdr (nth 3 attributes))))
      (weight-car (car (nth 4 attributes)))
      (weight-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 4 attributes))))
          'normal
          (cdr (nth 4 attributes))))
      (slant-car (car (nth 5 attributes)))
      (slant-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 5 attributes))))
          'normal
          (cdr (nth 5 attributes))))
      (underline-car (car (nth 6 attributes)))
      (underline-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 6 attributes))))
          nil
          (cdr (nth 6 attributes))))
      (overline-car (car (nth 7 attributes)))
      (overline-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 7 attributes))))
          nil
          (cdr (nth 7 attributes))))
      (strike-through-car (car (nth 8 attributes)))
      (strike-through-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 8 attributes))))
          nil
          (cdr (nth 8 attributes))))
      (box-car (car (nth 9 attributes)))
      (box-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 9 attributes))))
          nil
          (cdr (nth 9 attributes))))
      (inverse-video-car (car (nth 10 attributes)))
      (inverse-video-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 10 attributes))))
          nil
          (cdr (nth 10 attributes))))
      (foreground-car (car (nth 11 attributes)))
      (foreground-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 11 attributes))))
          'unspecified
          (cdr (nth 11 attributes))))
      (background-car (car (nth 12 attributes)))
      (background-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 12 attributes))))
          'unspecified
          (cdr (nth 12 attributes))))
      (stipple-car (car (nth 13 attributes)))
      (stipple-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 13 attributes))))
          nil
          (cdr (nth 13 attributes))))
      (inherit-car (car (nth 14 attributes)))
      (inherit-cdr
        (if (equal "unspecified" (format "%s" (cdr (nth 14 attributes))))
          nil
          (cdr (nth 14 attributes)))))
    (list
      family-car family-cdr
      foundry-car foundry-cdr
      width-car width-cdr
      height-car height-cdr
      weight-car weight-cdr
      slant-car slant-cdr
      underline-car underline-cdr
      overline-car overline-cdr
      strike-through-car strike-through-cdr
      box-car box-cdr
      inverse-video-car inverse-video-cdr
      foreground-car foreground-cdr
      background-car background-cdr
      stipple-car stipple-cdr
      inherit-car inherit-cdr)))
2

This is what I use, from library eyedropper.el. (Note the comment about the foreground not being specified by a named face.)

(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")
  ;; `eyedrop-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 (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) ; Emacs 22+.
                         (error (or (face-foreground face) ; Emacs 20
                                    (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)))         ; Invalid face value.
         (fg    (and (not (member fg '("unspecified-fg" "unspecified-bg")))  fg)))
    (when msg-p
      (if fg (eyedrop-color-message fg) (message "No foreground color here")))
    fg))

And this, slightly better, is the version from library palette.el (Color Palette).

(defun palette-foreground-at-point (&optional msg-p)
  "Return the foreground color under the text cursor.
Display it in a message, respecting option `palette-hex-rgb-digits'.
Return the full value, however, ignoring `palette-hex-rgb-digits'.

There need be no defined face at the cursor position (point).

Non-interactively, non-nil optional arg MSG-P means display an
informative message."
  (interactive "p")
  ;; Outside the palette, we need to check both for a named face (via `palette-face-at-point')
  ;; and face properties that are not associated with named faces.
  ;; Inside the palette, there is no need to check for a named face.
  (let* ((face  (or (and (not (eq major-mode 'palette-mode))
                         (palette-face-at-point))
                    (get-char-property (point) 'read-face-name)
                    (get-char-property (point) 'face)
                    'default))
         (fg    (cond ((and face (symbolp face))
                       (condition-case nil
                           (face-foreground face nil 'default) ; Emacs 22.
                         (error (or (face-foreground face) ; Emacs 20
                                    (cdr (assq 'foreground-color (frame-parameters)))))))
                      ((consp face)
                       (cond ((eq 'foreground-color (car face)) (cdr face))
                             ((and (consp (cdr face)) (memq 'foreground-color face))
                              (cdr (memq 'foreground-color face)))
                             ((and (consp (cdr face)) (memq ':foreground face))
                              (cadr (memq ':foreground face)))
                             (t (cdr (assq 'foreground-color (frame-parameters)))))) ; No fg.
                      (t nil)))         ; Invalid face value.
         (fg    (and (not (member fg '("unspecified-fg" "unspecified-bg")))  fg)))
    (when msg-p (if fg (palette-color-message fg t) (message "No foreground color here")))
    fg))
  • The following line of code causes fg (i.e., the name) to be reset and instead become t rather than the foreground name: (fg (and fg (not (member fg '("unspecified-fg" "unspecified-bg"))))) This would likely occur with the other similar function too -- i.e., eyedrop-background-at-point. – lawlist May 9 '15 at 20:36
  • @lawlist: Thx; should be OK now. The two args to and were reversed. – Drew May 9 '15 at 20:47
0

There is a function foreground-color-at-point in faces.el. It plays badly with overlays, but that's also the case for the functions mentioned by Drew.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.