[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 7ccedcb 1/2: * lisp/faces.el: Refactor common code
From: |
Artur Malabarba |
Subject: |
[Emacs-diffs] master 7ccedcb 1/2: * lisp/faces.el: Refactor common code and fix a bug |
Date: |
Fri, 30 Oct 2015 17:16:35 +0000 |
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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;