procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Roland Winkler 2013-04-12 20:10:09 -05:00
parent 562c6ee945
commit 011cddd649
6 changed files with 104 additions and 101 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
lisp/ChangeLog
View file

@ -1,3 +1,21 @@
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>
* info.el (Info-file-list-for-emacs): Add "tramp" and "dbus".

6
lisp/cus-edit.el
View file

@ -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,
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 ""))
(setq face (face-list)))
(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.
Interactively, when point is on text which has a face specified,
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))
(defalias 'customize-customized 'customize-unsaved)

2
lisp/cus-theme.el
View file

@ -263,7 +263,7 @@ interactively, this defaults to the current value of VAR."
(defun custom-theme-add-face (face &optional spec)
"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."
(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)
(error "`%s' has no face definition" face))
(let ((entry (assq face custom-theme-faces)))

2
lisp/face-remap.el
View file

@ -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
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)))
(setq specs (car specs)))
(if (null specs)

2
lisp/facemenu.el
View file

@ -329,7 +329,7 @@ This command can also add FACE to the menu of faces,
if `facemenu-listed-faces' says to do that."
(interactive (list (progn
(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))
(region-beginning))
(if (and mark-active (not current-prefix-arg))

175
lisp/faces.el
View file

@ -757,7 +757,8 @@ is specified, `:italic' is ignored."
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
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))
@ -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.
FRAME nil or not specified means change face on all frames.
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))
@ -774,7 +776,8 @@ Argument NOERROR is ignored and retained for compatibility."
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
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))
@ -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.
FRAME nil or not specified means change face on all frames.
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))
@ -791,7 +795,8 @@ Argument NOERROR is ignored and retained for compatibility."
FRAME nil or not specified means change face on all frames.
Argument NOERROR is ignored and retained for compatibility.
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))
@ -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,
set its foreground and background to the background and foreground
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))
(bg (face-attribute face :background frame)))
(if (not (and (eq fg 'unspecified) (eq bg 'unspecified)))
@ -929,85 +934,54 @@ of the default face. Value is FACE."
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read-face-name (prompt &optional default multiple)
"Read one or more face names, defaulting to the face(s) at point.
PROMPT should be a prompt string; it should not end in a space or
a colon.
"Read one or more face names, prompting with PROMPT.
PROMPT should not end in a space or a colon.
The optional argument DEFAULT specifies the default face name(s)
to return if the user just types RET. If its value is non-nil,
it should be a list of face names (symbols or strings); in that case,
the default return value is the `car' of DEFAULT (if the argument
MULTIPLE is non-nil), or DEFAULT (if MULTIPLE is nil). See below
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.
Return DEFAULT if the user enters the empty string.
If DEFAULT is non-nil, it should be a list of face names (symbols or strings).
In that case, return the `car' of DEFAULT (if MULTIPLE is non-nil),
or DEFAULT (if MULTIPLE is nil). See below for the meaning of MULTIPLE.
DEFAULT can also be a single face.
This function uses `completing-read-multiple' with \"[ \\t]*,[ \\t]*\"
as the separator regexp. Thus, the user may enter multiple face
names, separated by commas. The optional argument MULTIPLE
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
name, the return value would be a list of one face name.
Otherwise, return a single face name; if the user entered more
than one face name, return only the first one."
;; Should we better not generate automagically a value for DEFAULT
;; when `read-face-name' was called with DEFAULT being nil?
;; Such magic is somewhat unusual for a function `read-...'.
;; Also, one cannot skip this magic by means of a suitable
;; value of DEFAULT. It would be cleaner to use
;; (read-face-name prompt (face-at-point)).
(unless default
;; Try to get a default face name from the buffer.
(let ((thing (intern-soft (thing-at-point 'symbol))))
(if (memq thing (face-list))
(setq default (list thing))))
;; Add the named faces that the `read-face-name' or `face' property uses.
(let ((faceprop (or (get-char-property (point) 'read-face-name)
(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)))
as the separator regexp. Thus, the user may enter multiple face names,
separated by commas.
;; 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))))
MULTIPLE 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 name,
return a list of one face name. Otherwise, return a single face name;
if the user entered more than one face name, return only the first one."
(if (and default (not (stringp default)))
(setq default
(cond ((symbolp default)
(symbol-name default))
(multiple
(mapconcat (lambda (f) (if (symbolp f) (symbol-name f) f))
default ", "))
;; If we only want one, and the default is more than one,
;; discard the unwanted ones.
(t (symbol-name (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)
(let (aliasfaces nonaliasfaces faces)
;; Build up the completion tables.
(mapatoms (lambda (s)
(if (custom-facep s)
(if (facep s)
(if (get s 'face-alias)
(push (symbol-name s) aliasfaces)
(push (symbol-name s) nonaliasfaces)))))
(let ((faces
;; Read the faces.
(mapcar 'intern
(completing-read-multiple
(if default
(format "%s (default `%s'): " prompt default)
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history default))))
;; Return either a list of faces or just one face.
(if multiple
faces
(car faces)))))
(dolist (face (completing-read-multiple
(if default
(format "%s (default `%s'): " prompt default)
(format "%s: " prompt))
(completion-table-in-turn nonaliasfaces aliasfaces)
nil t nil 'face-name-history default))
;; Ignore elements that are not faces
;; (for example, because DEFAULT was "all faces")
(if (facep face) (push (intern face) faces)))
;; Return either a list of faces or just one face.
(if multiple
(nreverse faces)
(last faces))))
;; Not defined without X, but behind window-system test.
(defvar x-bitmap-file-path)
@ -1235,7 +1209,7 @@ and the face and its settings are obtained by querying the user."
:slant (if italic-p 'italic 'normal)
:underline underline
: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
(read-all-face-attributes face frame))))
@ -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."
(cond ((eq attribute :font)
(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)))
(list face font)))
(t
(let* ((attribute-name (face-descriptive-attribute-name attribute))
(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)))
(list face new-value)))))
@ -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 omitted or nil, use the selected frame."
(interactive (list (read-face-name "Describe face"
(if (eq 'default (face-at-point))
'(default))
(or (face-at-point t) 'default)
t)))
(let* ((attrs '((:family . "Family")
(:foundry . "Foundry")
@ -1879,23 +1852,33 @@ resulting color name in the echo area."
(when msg (message "Color: `%s'" color))
color))
(defun face-at-point ()
(defun face-at-point (&optional thing multiple)
"Return the face of the character after point.
If it has more than one face, return the first one.
Return nil if it has no specified face."
(let* ((faceprop (or (get-char-property (point) 'read-face-name)
(get-char-property (point) 'face)
'default))
(face (cond ((symbolp faceprop) faceprop)
;; List of faces (don't treat an attribute spec).
;; Just use the first face.
((and (consp faceprop) (not (keywordp (car faceprop)))
(not (memq (car faceprop)
'(foreground-color background-color))))
(car faceprop))
(t nil)))) ; Invalid face value.
(if (facep face) face nil)))
If THING is non-nil try first to get a face name from the buffer.
IF MULTIPLE is non-nil, return a list of all faces.
Return nil if there is no face."
(let (faces)
(if thing
;; Try to get a face name from the buffer.
(let ((face (intern-soft (thing-at-point 'symbol))))
(if (facep face)
(push face faces))))
;; Add the named faces that the `read-face-name' or `face' property uses.
(let ((faceprop (or (get-char-property (point) 'read-face-name)
(get-char-property (point) 'face))))
(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 ()
"Return the foreground color of the character after point."