GNU bug report logs - #22757
25.1.50; `face-at-point` and `faces--attribute-at-point` -- add argument WINDOW-OR-BUFFER

Previous Next

Full log

View this message in rfc822 format

From: Keith David Bershatsky <esq <at> lawlist.com>
To: Eli Zaretskii <eliz <at> gnu.org>
Cc: 22757 <at> debbugs.gnu.org
Subject: bug#22757: 25.1.50; `face-at-point` and `faces--attribute-at-point` -- add argument WINDOW-OR-BUFFER
Date: Mon, 22 Feb 2016 11:46:39 -0800

Here is the custom function that I came up with, derived in part from `faces.el`, `color.el` and from Drew's color libraries.

(defun color-vector-calc (buffer-or-window pos fg-or-bg)
"Calculate the color vector of either :foreground or :background for the face at POS.
Sample usage:  (color-vector-calc (selected-window) (point) 'foreground)
The first argument BUFFER-OR-WINDOW is used in the context of `get-char-property'.
The second argument POS is a user specified `point' somewhere in the buffer/window.
The third argument FG-OR-BG is a symbol of either 'foreground or 'background"
  (let* (
      (frame (selected-frame))
      (+-default-face-fg
        (face-attribute-specified-or (face-attribute 'default :foreground frame 'default) nil))
      (+-default-face-bg
        (face-attribute-specified-or (face-attribute 'default :background frame 'default) nil))
      (faceprop
        (or
          (get-char-property pos 'read-face-name buffer-or-window)
          (get-char-property pos 'face buffer-or-window)
          'default))
      (face
        (cond
          ((symbolp faceprop) faceprop)
          ((and (consp faceprop) (not (keywordp (car faceprop)))
                (not (memq (car faceprop) '(foreground-color background-color))))
           (car faceprop))
          (t ;; e.g., (:foreground yellow)
            faceprop)))
      (color
        (cond
            ((and face (symbolp face))
            (if (eq 'foreground fg-or-bg)
              (face-attribute-specified-or (face-attribute face :foreground frame 'default) nil)
              (face-attribute-specified-or (face-attribute face :background frame 'default) nil)))
          ((and (eq 'foreground fg-or-bg) (consp face))
            (cond
              ((memq 'foreground-color face)
                (cdr (memq 'foreground-color face)))
              ((memq ':foreground face)
                (cadr (memq ':foreground face)))
              (t +-default-face-fg)))
          ((and (eq 'background fg-or-bg) (consp face))
            (cond
              ((memq 'background-color face)
                (cdr (memq 'background-color face)))
              ((memq ':background face)
                (cadr (memq ':background face)))
              (t +-default-face-bg)))
          (t
            (if (eq 'foreground fg-or-bg)
              +-default-face-fg
              +-default-face-bg))))
      (color-values
        (cond
         ((member color '(unspecified "unspecified-fg" "unspecified-bg"))
          nil)
         ((memq (framep (or frame (selected-frame))) '(x w32 ns))
          (xw-color-values color frame))
         (t
          (tty-color-values color frame))))
      (value
        (mapcar
          (lambda (x)
            (let* (
              (valmax
                (cond
                 ((memq (framep (or frame (selected-frame))) '(x w32 ns))
                  (xw-color-values "#ffffff" frame))
                 (t
                  (tty-color-values "#ffffff" frame))))
              (+-valmax (float (car valmax))))
              (/ x +-valmax)))
          color-values)) )
    (vconcat value)))

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.