-(defun read-face-name (prompt)
- "Read and return a face symbol, prompting with PROMPT.
-PROMPT should not end with a blank, since this function appends one.
-Value is a symbol naming a known face."
- (let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x))
- (face-list)))
- (def (thing-at-point 'symbol))
- face)
- (cond ((assoc def face-list)
- (setq prompt (concat prompt " (default " def "): ")))
- (t (setq def nil)
- (setq prompt (concat prompt ": "))))
- (while (equal "" (setq face (completing-read
- prompt face-list nil t nil nil def))))
- (intern face)))
+(defun read-face-name (prompt &optional string-describing-default multiple)
+ "Read a face, defaulting to the face or faces on the char after point.
+If it has a `read-face-name' property, that overrides the `face' property.
+PROMPT describes what you will do with the face (don't end in a space).
+STRING-DESCRIBING-DEFAULT describes what default you will use
+if this function returns nil.
+If MULTIPLE is non-nil, return a list of faces (possibly only one).
+Otherwise, return a single face."
+ (let ((faceprop (or (get-char-property (point) 'read-face-name)
+ (get-char-property (point) 'face)))
+ faces)
+ ;; Make a list of 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)))
+ ;; If there are none, try to get a face name from the buffer.
+ (if (and (null faces)
+ (memq (intern-soft (thing-at-point 'symbol)) (face-list)))
+ (setq faces (list (intern-soft (thing-at-point 'symbol)))))
+
+ ;; 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)))))
+ (let* ((input
+ ;; Read the input.
+ (completing-read
+ (if (or faces string-describing-default)
+ (format "%s (default %s): " prompt
+ (if faces (mapconcat 'symbol-name faces ", ")
+ string-describing-default))
+ (format "%s: " prompt))
+ obarray 'custom-facep t))
+ ;; Canonicalize the output.
+ (output
+ (if (equal input "")
+ faces
+ (if (stringp input)
+ (list (intern input))
+ input))))
+ ;; Return either a list of faces or just one face.
+ (if multiple
+ output
+ (car output)))))