Commit 011cddd6 authored by Roland Winkler's avatar Roland Winkler
Browse files

faces.el (read-face-name): Do not override value of arg default, call instead face-at-point

parent 562c6ee9
2013-04-12 Roland Winkler <winkler@gnu.org>
* faces.el (read-face-name): Do not override value of arg default.
Allow single faces and strings as default values. Remove those
elements from return value that are not faces.
(describe-face): Simplify.
(face-at-point): New optional args thing and multiple so that this
function can provide the same functionality previously provided by
read-face-name.
(make-face-bold, make-face-unbold, make-face-italic)
(make-face-unitalic, make-face-bold-italic, invert-face)
(modify-face, read-face-and-attribute): Use face-at-point.
* cus-edit.el (customize-face, customize-face-other-window)
* cus-theme.el (custom-theme-add-face)
* face-remap.el (buffer-face-set)
* facemenu.el (facemenu-set-face): Use face-at-point.
2013-04-12 Michael Albinus <michael.albinus@gmx.de> 2013-04-12 Michael Albinus <michael.albinus@gmx.de>
   
* info.el (Info-file-list-for-emacs): Add "tramp" and "dbus". * info.el (Info-file-list-for-emacs): Add "tramp" and "dbus".
......
...@@ -1319,7 +1319,8 @@ If OTHER-WINDOW is non-nil, display in another window. ...@@ -1319,7 +1319,8 @@ If OTHER-WINDOW is non-nil, display in another window.
Interactively, when point is on text which has a face specified, Interactively, when point is on text which has a face specified,
suggest to customize that face, if it's customizable." suggest to customize that face, if it's customizable."
(interactive (list (read-face-name "Customize face" "all faces" t))) (interactive (list (read-face-name "Customize face"
(or (face-at-point t t) "all faces") t)))
(if (member face '(nil "")) (if (member face '(nil ""))
(setq face (face-list))) (setq face (face-list)))
(if (and (listp face) (null (cdr face))) (if (and (listp face) (null (cdr face)))
...@@ -1350,7 +1351,8 @@ If FACE is actually a face-alias, customize the face it is aliased to. ...@@ -1350,7 +1351,8 @@ If FACE is actually a face-alias, customize the face it is aliased to.
Interactively, when point is on text which has a face specified, Interactively, when point is on text which has a face specified,
suggest to customize that face, if it's customizable." suggest to customize that face, if it's customizable."
(interactive (list (read-face-name "Customize face" "all faces" t))) (interactive (list (read-face-name "Customize face"
(or (face-at-point t t) "all faces") t)))
(customize-face face t)) (customize-face face t))
(defalias 'customize-customized 'customize-unsaved) (defalias 'customize-customized 'customize-unsaved)
......
...@@ -263,7 +263,7 @@ interactively, this defaults to the current value of VAR." ...@@ -263,7 +263,7 @@ interactively, this defaults to the current value of VAR."
(defun custom-theme-add-face (face &optional spec) (defun custom-theme-add-face (face &optional spec)
"Add a widget for FACE (a symbol) to the *New Custom Theme* buffer. "Add a widget for FACE (a symbol) to the *New Custom Theme* buffer.
SPEC, if non-nil, should be a face spec to which to set the widget." SPEC, if non-nil, should be a face spec to which to set the widget."
(interactive (list (read-face-name "Face name" nil nil) nil)) (interactive (list (read-face-name "Face name" (face-at-point t))))
(unless (or (facep face) spec) (unless (or (facep face) spec)
(error "`%s' has no face definition" face)) (error "`%s' has no face definition" face))
(let ((entry (assq face custom-theme-faces))) (let ((entry (assq face custom-theme-faces)))
......
...@@ -378,7 +378,7 @@ one face is listed, that specifies an aggregate face, like in a ...@@ -378,7 +378,7 @@ one face is listed, that specifies an aggregate face, like in a
This function makes the variable `buffer-face-mode-face' buffer This function makes the variable `buffer-face-mode-face' buffer
local, and sets it to FACE." local, and sets it to FACE."
(interactive (list (read-face-name "Set buffer face"))) (interactive (list (read-face-name "Set buffer face" (face-at-point t))))
(while (and (consp specs) (null (cdr specs))) (while (and (consp specs) (null (cdr specs)))
(setq specs (car specs))) (setq specs (car specs)))
(if (null specs) (if (null specs)
......
...@@ -329,7 +329,7 @@ This command can also add FACE to the menu of faces, ...@@ -329,7 +329,7 @@ This command can also add FACE to the menu of faces,
if `facemenu-listed-faces' says to do that." if `facemenu-listed-faces' says to do that."
(interactive (list (progn (interactive (list (progn
(barf-if-buffer-read-only) (barf-if-buffer-read-only)
(read-face-name "Use face")) (read-face-name "Use face" (face-at-point t)))
(if (and mark-active (not current-prefix-arg)) (if (and mark-active (not current-prefix-arg))
(region-beginning)) (region-beginning))
(if (and mark-active (not current-prefix-arg)) (if (and mark-active (not current-prefix-arg))
......
...@@ -757,7 +757,8 @@ is specified, `:italic' is ignored." ...@@ -757,7 +757,8 @@ is specified, `:italic' is ignored."
FRAME nil or not specified means change face on all frames. FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility. Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font weight." Use `set-face-attribute' for finer control of the font weight."
(interactive (list (read-face-name "Make which face bold"))) (interactive (list (read-face-name "Make which face bold"
(face-at-point t))))
(set-face-attribute face frame :weight 'bold)) (set-face-attribute face frame :weight 'bold))
...@@ -765,7 +766,8 @@ Use `set-face-attribute' for finer control of the font weight." ...@@ -765,7 +766,8 @@ Use `set-face-attribute' for finer control of the font weight."
"Make the font of FACE be non-bold, if possible. "Make the font of FACE be non-bold, if possible.
FRAME nil or not specified means change face on all frames. FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility." Argument NOERROR is ignored and retained for compatibility."
(interactive (list (read-face-name "Make which face non-bold"))) (interactive (list (read-face-name "Make which face non-bold"
(face-at-point t))))
(set-face-attribute face frame :weight 'normal)) (set-face-attribute face frame :weight 'normal))
...@@ -774,7 +776,8 @@ Argument NOERROR is ignored and retained for compatibility." ...@@ -774,7 +776,8 @@ Argument NOERROR is ignored and retained for compatibility."
FRAME nil or not specified means change face on all frames. FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility. Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of the font slant." Use `set-face-attribute' for finer control of the font slant."
(interactive (list (read-face-name "Make which face italic"))) (interactive (list (read-face-name "Make which face italic"
(face-at-point t))))
(set-face-attribute face frame :slant 'italic)) (set-face-attribute face frame :slant 'italic))
...@@ -782,7 +785,8 @@ Use `set-face-attribute' for finer control of the font slant." ...@@ -782,7 +785,8 @@ Use `set-face-attribute' for finer control of the font slant."
"Make the font of FACE be non-italic, if possible. "Make the font of FACE be non-italic, if possible.
FRAME nil or not specified means change face on all frames. FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility." Argument NOERROR is ignored and retained for compatibility."
(interactive (list (read-face-name "Make which face non-italic"))) (interactive (list (read-face-name "Make which face non-italic"
(face-at-point t))))
(set-face-attribute face frame :slant 'normal)) (set-face-attribute face frame :slant 'normal))
...@@ -791,7 +795,8 @@ Argument NOERROR is ignored and retained for compatibility." ...@@ -791,7 +795,8 @@ Argument NOERROR is ignored and retained for compatibility."
FRAME nil or not specified means change face on all frames. FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility. Argument NOERROR is ignored and retained for compatibility.
Use `set-face-attribute' for finer control of font weight and slant." Use `set-face-attribute' for finer control of font weight and slant."
(interactive (list (read-face-name "Make which face bold-italic"))) (interactive (list (read-face-name "Make which face bold-italic"
(face-at-point t))))
(set-face-attribute face frame :weight 'bold :slant 'italic)) (set-face-attribute face frame :weight 'bold :slant 'italic))
...@@ -911,7 +916,7 @@ If FRAME is omitted or nil, it means change face on all frames. ...@@ -911,7 +916,7 @@ If FRAME is omitted or nil, it means change face on all frames.
If FACE specifies neither foreground nor background color, If FACE specifies neither foreground nor background color,
set its foreground and background to the background and foreground set its foreground and background to the background and foreground
of the default face. Value is FACE." of the default face. Value is FACE."
(interactive (list (read-face-name "Invert face"))) (interactive (list (read-face-name "Invert face" (face-at-point t))))
(let ((fg (face-attribute face :foreground frame)) (let ((fg (face-attribute face :foreground frame))
(bg (face-attribute face :background frame))) (bg (face-attribute face :background frame)))
(if (not (and (eq fg 'unspecified) (eq bg 'unspecified))) (if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
...@@ -929,85 +934,54 @@ of the default face. Value is FACE." ...@@ -929,85 +934,54 @@ of the default face. Value is FACE."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-face-name (prompt &optional default multiple) (defun read-face-name (prompt &optional default multiple)
"Read one or more face names, defaulting to the face(s) at point. "Read one or more face names, prompting with PROMPT.
PROMPT should be a prompt string; it should not end in a space or PROMPT should not end in a space or a colon.
a colon.
The optional argument DEFAULT specifies the default face name(s) Return DEFAULT if the user enters the empty string.
to return if the user just types RET. If its value is non-nil, If DEFAULT is non-nil, it should be a list of face names (symbols or strings).
it should be a list of face names (symbols or strings); in that case, In that case, return the `car' of DEFAULT (if MULTIPLE is non-nil),
the default return value is the `car' of DEFAULT (if the argument or DEFAULT (if MULTIPLE is nil). See below for the meaning of MULTIPLE.
MULTIPLE is non-nil), or DEFAULT (if MULTIPLE is nil). See below DEFAULT can also be a single face.
for the meaning of MULTIPLE.
If DEFAULT is nil, the list of default face names is taken from
the symbol at point and the `read-face-name' property of the text at point,
or, if that is nil, from the `face' property of the text at point.
This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\" This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\"
as the separator regexp. Thus, the user may enter multiple face as the separator regexp. Thus, the user may enter multiple face names,
names, separated by commas. The optional argument MULTIPLE separated by commas.
specifies the form of the return value. If MULTIPLE is non-nil,
return a list of face names; if the user entered just one face MULTIPLE specifies the form of the return value. If MULTIPLE is non-nil,
name, the return value would be a list of one face name. return a list of face names; if the user entered just one face name,
Otherwise, return a single face name; if the user entered more return a list of one face name. Otherwise, return a single face name;
than one face name, return only the first one." if the user entered more than one face name, return only the first one."
;; Should we better not generate automagically a value for DEFAULT (if (and default (not (stringp default)))
;; when `read-face-name' was called with DEFAULT being nil? (setq default
;; Such magic is somewhat unusual for a function `read-...'. (cond ((symbolp default)
;; Also, one cannot skip this magic by means of a suitable (symbol-name default))
;; value of DEFAULT. It would be cleaner to use (multiple
;; (read-face-name prompt (face-at-point)). (mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
(unless default default ", "))
;; Try to get a default face name from the buffer. ;; If we only want one, and the default is more than one,
(let ((thing (intern-soft (thing-at-point 'symbol)))) ;; discard the unwanted ones.
(if (memq thing (face-list)) (t (symbol-name (car default))))))
(setq default (list thing))))
;; Add the named faces that the `read-face-name' or `face' property uses. (let (aliasfaces nonaliasfaces faces)
(let ((faceprop (or (get-char-property (point) 'read-face-name) ;; Build up the completion tables.
(get-char-property (point) 'face))))
(if (and (listp faceprop)
;; Don't treat an attribute spec as a list of faces.
(not (keywordp (car faceprop)))
(not (memq (car faceprop) '(foreground-color background-color))))
(dolist (face faceprop)
(if (symbolp face)
(push face default)))
(if (symbolp faceprop)
(push faceprop default)))
(delete-dups default)))
;; If we only want one, and the default is more than one,
;; discard the unwanted ones now.
(if (and default (not multiple))
(setq default (list (car default))))
(if default
(setq default (mapconcat (lambda (f)
(if (symbolp f) (symbol-name f) f))
default ", ")))
;; Build up the completion tables.
(let (aliasfaces nonaliasfaces)
(mapatoms (lambda (s) (mapatoms (lambda (s)
(if (custom-facep s) (if (facep s)
(if (get s 'face-alias) (if (get s 'face-alias)
(push (symbol-name s) aliasfaces) (push (symbol-name s) aliasfaces)
(push (symbol-name s) nonaliasfaces))))) (push (symbol-name s) nonaliasfaces)))))
(dolist (face (completing-read-multiple
(let ((faces (if default
;; Read the faces. (format "%s (default `%s'): " prompt default)
(mapcar 'intern (format "%s: " prompt))
(completing-read-multiple (completion-table-in-turn nonaliasfaces aliasfaces)
(if default nil t nil 'face-name-history default))
(format "%s (default `%s'): " prompt default) ;; Ignore elements that are not faces
(format "%s: " prompt)) ;; (for example, because DEFAULT was "all faces")
(completion-table-in-turn nonaliasfaces aliasfaces) (if (facep face) (push (intern face) faces)))
nil t nil 'face-name-history default)))) ;; Return either a list of faces or just one face.
;; Return either a list of faces or just one face. (if multiple
(if multiple (nreverse faces)
faces (last faces))))
(car faces)))))
;; Not defined without X, but behind window-system test. ;; Not defined without X, but behind window-system test.
(defvar x-bitmap-file-path) (defvar x-bitmap-file-path)
...@@ -1235,7 +1209,7 @@ and the face and its settings are obtained by querying the user." ...@@ -1235,7 +1209,7 @@ and the face and its settings are obtained by querying the user."
:slant (if italic-p 'italic 'normal) :slant (if italic-p 'italic 'normal)
:underline underline :underline underline
:inverse-video inverse-p) :inverse-video inverse-p)
(setq face (read-face-name "Modify face")) (setq face (read-face-name "Modify face" (face-at-point t)))
(apply #'set-face-attribute face frame (apply #'set-face-attribute face frame
(read-all-face-attributes face frame)))) (read-all-face-attributes face frame))))
...@@ -1247,13 +1221,13 @@ Value is a list (FACE NEW-VALUE) where FACE is the face read ...@@ -1247,13 +1221,13 @@ Value is a list (FACE NEW-VALUE) where FACE is the face read
\(a symbol), and NEW-VALUE is value read." \(a symbol), and NEW-VALUE is value read."
(cond ((eq attribute :font) (cond ((eq attribute :font)
(let* ((prompt "Set font-related attributes of face") (let* ((prompt "Set font-related attributes of face")
(face (read-face-name prompt)) (face (read-face-name prompt (face-at-point t)))
(font (read-face-font face frame))) (font (read-face-font face frame)))
(list face font))) (list face font)))
(t (t
(let* ((attribute-name (face-descriptive-attribute-name attribute)) (let* ((attribute-name (face-descriptive-attribute-name attribute))
(prompt (format "Set %s of face" attribute-name)) (prompt (format "Set %s of face" attribute-name))
(face (read-face-name prompt)) (face (read-face-name prompt (face-at-point t)))
(new-value (read-face-attribute face attribute frame))) (new-value (read-face-attribute face attribute frame)))
(list face new-value))))) (list face new-value)))))
...@@ -1363,8 +1337,7 @@ If the optional argument FRAME is given, report on face FACE in that frame. ...@@ -1363,8 +1337,7 @@ If the optional argument FRAME is given, report on face FACE in that frame.
If FRAME is t, report on the defaults for face FACE (for new frames). If FRAME is t, report on the defaults for face FACE (for new frames).
If FRAME is omitted or nil, use the selected frame." If FRAME is omitted or nil, use the selected frame."
(interactive (list (read-face-name "Describe face" (interactive (list (read-face-name "Describe face"
(if (eq 'default (face-at-point)) (or (face-at-point t) 'default)
'(default))
t))) t)))
(let* ((attrs '((:family . "Family") (let* ((attrs '((:family . "Family")
(:foundry . "Foundry") (:foundry . "Foundry")
...@@ -1879,23 +1852,33 @@ resulting color name in the echo area." ...@@ -1879,23 +1852,33 @@ resulting color name in the echo area."
(when msg (message "Color: `%s'" color)) (when msg (message "Color: `%s'" color))
color)) color))
(defun face-at-point (&optional thing multiple)
(defun face-at-point ()
"Return the face of the character after point. "Return the face of the character after point.
If it has more than one face, return the first one. If it has more than one face, return the first one.
Return nil if it has no specified face." If THING is non-nil try first to get a face name from the buffer.
(let* ((faceprop (or (get-char-property (point) 'read-face-name) IF MULTIPLE is non-nil, return a list of all faces.
(get-char-property (point) 'face) Return nil if there is no face."
'default)) (let (faces)
(face (cond ((symbolp faceprop) faceprop) (if thing
;; List of faces (don't treat an attribute spec). ;; Try to get a face name from the buffer.
;; Just use the first face. (let ((face (intern-soft (thing-at-point 'symbol))))
((and (consp faceprop) (not (keywordp (car faceprop))) (if (facep face)
(not (memq (car faceprop) (push face faces))))
'(foreground-color background-color)))) ;; Add the named faces that the `read-face-name' or `face' property uses.
(car faceprop)) (let ((faceprop (or (get-char-property (point) 'read-face-name)
(t nil)))) ; Invalid face value. (get-char-property (point) 'face))))
(if (facep face) face nil))) (cond ((facep faceprop)
(push faceprop faces))
((and (listp faceprop)
;; Don't treat an attribute spec as a list of faces.
(not (keywordp (car faceprop)))
(not (memq (car faceprop)
'(foreground-color background-color))))
(dolist (face faceprop)
(if (facep face)
(push face faces))))))
(setq faces (delete-dups (nreverse faces)))
(if multiple faces (car faces))))
(defun foreground-color-at-point () (defun foreground-color-at-point ()
"Return the foreground color of the character after point." "Return the foreground color of the character after point."
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment