[Emacs-diffs] master 7ccedcb 1/2: * lisp/faces.el: Refactor common code and fix a bug

[Artur Malabarba]

branch: master
commit 7ccedcb486ee4e37da54dd82a8557c80616d9467
Author: Artur Malabarba <address@hidden>
Commit: Artur Malabarba <address@hidden>

    * lisp/faces.el: Refactor common code and fix a bug
    
    (faces--attribute-at-point): New function.  Fix a bug when the
    face at point is a list of faces and the desired attribute is not
    on the first one.
    (foreground-color-at-point, background-color-at-point): Use it.
---
 lisp/faces.el |   58 +++++++++++++++++++++++++++++---------------------------
 1 files changed, 30 insertions(+), 28 deletions(-)

diff --git a/lisp/faces.el b/lisp/faces.el
index de8a0b5..8c54809 100644
--- a/lisp/faces.el
+++ b/lisp/faces.el
@@ -1958,39 +1958,41 @@ Return nil if there is no face."
         (delete-dups (nreverse faces))
       (car (last faces)))))
 
-(defun foreground-color-at-point ()
-  "Return the foreground color of the character after point."
+(defun faces--attribute-at-point (attribute &optional attribute-unnamed)
+  "Return the face ATTRIBUTE at point.
+ATTRIBUTE is a keyword.
+If ATTRIBUTE-UNNAMED is non-nil, it is a symbol to look for in
+unnamed faces (e.g, `foreground-color')."
   ;; `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.
+  (let (found)
+    (dolist (face (or (get-char-property (point) 'read-face-name)
+                      ;; If `font-lock-mode' is on, `font-lock-face' takes 
precedence.
+                      (and font-lock-mode
+                           (get-char-property (point) 'font-lock-face))
+                      (get-char-property (point) 'face)))
+      (cond (found)
+            ((and face (symbolp face))
+             (let ((value (face-attribute-specified-or
+                           (face-attribute face attribute nil t)
+                           nil)))
+               (unless (member value '(nil "unspecified-fg" "unspecified-bg"))
+                 (setq found value))))
+            ((consp face)
+             (setq found (cond ((and attribute-unnamed
+                                     (memq attribute-unnamed face))
+                                (cdr (memq attribute-unnamed face)))
+                               ((memq attribute face) (cadr (memq attribute 
face))))))))
+    (or found
+        (face-attribute 'default attribute))))
+
+(defun foreground-color-at-point ()
+  "Return the foreground color of the character after point."
+  (faces--attribute-at-point :foreground 'foreground-color))
 
 (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.
+  (faces--attribute-at-point :background 'background-color))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;