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))
"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))
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))
"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))
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))
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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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.
-
-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); 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 `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 \",\" as the
-separator character. 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."
- (let ((faceprop (or (get-char-property (point) 'read-face-name)
- (get-char-property (point) 'face)))
- (aliasfaces nil)
- (nonaliasfaces nil)
- faces)
- ;; Try to get a face name from the buffer.
- (if (memq (intern-soft (thing-at-point 'symbol)) (face-list))
- (setq faces (list (intern-soft (thing-at-point 'symbol)))))
- ;; Add the named faces that the `face' property uses.
- (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 (f faceprop)
- (if (symbolp f)
- (push f faces)))
- (if (symbolp faceprop)
- (push faceprop faces)))
- (delete-dups faces)
-
+ "Read one or more face names, prompting with PROMPT.
+PROMPT should not end in a space or a colon.
+
+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.
+
+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))))))
+
+ (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)))))
-
- ;; If we only want one, and the default is more than one,
- ;; discard the unwanted ones now.
- (unless multiple
- (if faces
- (setq faces (list (car faces)))))
- (require 'crm)
- (let* ((input
- ;; Read the input.
- (completing-read-multiple
- (if (or faces default)
- (format "%s (default `%s'): " prompt
- (if faces (mapconcat 'symbol-name faces ",")
- default))
- (format "%s: " prompt))
- (completion-table-in-turn nonaliasfaces aliasfaces)
- nil t nil 'face-name-history
- (if faces (mapconcat 'symbol-name faces ","))))
- ;; Canonicalize the output.
- (output
- (cond ((or (equal input "") (equal input '("")))
- (or faces (unless (stringp default) default)))
- ((stringp input)
- (mapcar 'intern (split-string input ", *" t)))
- ((listp input)
- (mapcar 'intern input))
- (input))))
- ;; Return either a list of faces or just one face.
- (if multiple
- output
- (car output)))))
+ (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)
: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))))
\(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)))))
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" 'default t)))
+ (interactive (list (read-face-name "Describe face"
+ (or (face-at-point t) 'default)
+ t)))
(let* ((attrs '((:family . "Family")
(:foundry . "Foundry")
(:width . "Width")
(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."
HCoop / bpt / emacs.git / blobdiff