846 |
;;; Interactively modifying faces. |
;;; Interactively modifying faces. |
847 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
848 |
|
|
849 |
(defun read-face-name (prompt) |
(defun read-face-name (prompt &optional string-describing-default multiple) |
850 |
"Read and return a face symbol, prompting with PROMPT. |
"Read a face, defaulting to the face or faces on the char after point. |
851 |
PROMPT should not end with a blank, since this function appends one. |
If it has a `read-face-name' property, that overrides the `face' property. |
852 |
Value is a symbol naming a known face." |
PROMPT describes what you will do with the face (don't end in a space). |
853 |
(let ((face-list (mapcar #'(lambda (x) (cons (symbol-name x) x)) |
STRING-DESCRIBING-DEFAULT describes what default you will use |
854 |
(face-list))) |
if this function returns nil. |
855 |
(def (thing-at-point 'symbol)) |
If MULTIPLE is non-nil, return a list of faces (possibly only one). |
856 |
face) |
Otherwise, return a single face." |
857 |
(cond ((assoc def face-list) |
(let ((faceprop (or (get-char-property (point) 'read-face-name) |
858 |
(setq prompt (concat prompt " (default " def "): "))) |
(get-char-property (point) 'face))) |
859 |
(t (setq def nil) |
faces) |
860 |
(setq prompt (concat prompt ": ")))) |
;; Make a list of the named faces that the `face' property uses. |
861 |
(while (equal "" (setq face (completing-read |
(if (listp faceprop) |
862 |
prompt face-list nil t nil nil def)))) |
(dolist (f faceprop) |
863 |
(intern face))) |
(if (symbolp f) |
864 |
|
(push f faces))) |
865 |
|
(if (symbolp faceprop) |
866 |
|
(setq faces (list faceprop)))) |
867 |
|
;; If there are none, try to get a face name from the buffer. |
868 |
|
(if (and (null faces) |
869 |
|
(memq (intern-soft (thing-at-point 'symbol)) (face-list))) |
870 |
|
(setq faces (list (intern-soft (thing-at-point 'symbol))))) |
871 |
|
|
872 |
|
;; If we only want one, and the default is more than one, |
873 |
|
;; discard the unwanted ones now. |
874 |
|
(unless multiple |
875 |
|
(if faces |
876 |
|
(setq faces (list (car faces))))) |
877 |
|
(let* ((input |
878 |
|
;; Read the input. |
879 |
|
(completing-read |
880 |
|
(if (or faces string-describing-default) |
881 |
|
(format "%s (default %s): " prompt |
882 |
|
(if faces (mapconcat 'symbol-name faces ", ") |
883 |
|
string-describing-default)) |
884 |
|
prompt) |
885 |
|
obarray 'custom-facep t)) |
886 |
|
;; Canonicalize the output. |
887 |
|
(output |
888 |
|
(if (equal input "") |
889 |
|
faces |
890 |
|
(if (stringp input) |
891 |
|
(list (intern input)) |
892 |
|
input)))) |
893 |
|
;; Return either a list of faces or just one face. |
894 |
|
(if multiple |
895 |
|
output |
896 |
|
(car output))))) |
897 |
|
|
898 |
|
|
899 |
|
|
900 |
|
|
901 |
(defun face-valid-attribute-values (attribute &optional frame) |
(defun face-valid-attribute-values (attribute &optional frame) |
1172 |
(save-excursion |
(save-excursion |
1173 |
(save-match-data |
(save-match-data |
1174 |
(search-backward face-name) |
(search-backward face-name) |
1175 |
(help-xref-button 0 'help-customize-face face-name))) |
(help-xref-button 0 'help-customize-face face))) |
1176 |
(let ((beg (point))) |
(let ((beg (point)) |
1177 |
|
(line-beg (line-beginning-position))) |
1178 |
(insert list-faces-sample-text) |
(insert list-faces-sample-text) |
1179 |
;; Hyperlink to a help buffer for the face. |
;; Hyperlink to a help buffer for the face. |
1180 |
(save-excursion |
(save-excursion |
1183 |
(help-xref-button 0 'help-face face))) |
(help-xref-button 0 'help-face face))) |
1184 |
(insert "\n") |
(insert "\n") |
1185 |
(put-text-property beg (1- (point)) 'face face) |
(put-text-property beg (1- (point)) 'face face) |
1186 |
|
;; Make all face commands default to the proper face |
1187 |
|
;; anywhere in the line. |
1188 |
|
(put-text-property line-beg (1- (point)) 'read-face-name face) |
1189 |
;; If the sample text has multiple lines, line up all of them. |
;; If the sample text has multiple lines, line up all of them. |
1190 |
(goto-char beg) |
(goto-char beg) |
1191 |
(forward-line 1) |
(forward-line 1) |
1206 |
(copy-face (car faces) (car faces) frame disp-frame) |
(copy-face (car faces) (car faces) frame disp-frame) |
1207 |
(setq faces (cdr faces))))))) |
(setq faces (cdr faces))))))) |
1208 |
|
|
|
|
|
1209 |
(defun describe-face (face &optional frame) |
(defun describe-face (face &optional frame) |
1210 |
"Display the properties of face FACE on FRAME. |
"Display the properties of face FACE on FRAME. |
1211 |
|
Interactevely, FACE defaults to the faces of the character after point |
1212 |
|
and FRAME defaults to the selected frame. |
1213 |
|
|
1214 |
If the optional argument FRAME is given, report on face FACE in that frame. |
If the optional argument FRAME is given, report on face FACE in that frame. |
1215 |
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). |
1216 |
If FRAME is omitted or nil, use the selected frame." |
If FRAME is omitted or nil, use the selected frame." |
1217 |
(interactive (list (read-face-name "Describe face"))) |
(interactive (list (read-face-name "Describe face" "= `default' face" t))) |
1218 |
(let* ((attrs '((:family . "Family") |
(let* ((attrs '((:family . "Family") |
1219 |
(:width . "Width") |
(:width . "Width") |
1220 |
(:height . "Height") |
(:height . "Height") |
1233 |
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) |
(max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) |
1234 |
attrs)))) |
attrs)))) |
1235 |
(help-setup-xref (list #'describe-face face) (interactive-p)) |
(help-setup-xref (list #'describe-face face) (interactive-p)) |
1236 |
|
(unless face |
1237 |
|
(setq face 'default)) |
1238 |
|
(if (not (listp face)) |
1239 |
|
(setq face (list face))) |
1240 |
(with-output-to-temp-buffer (help-buffer) |
(with-output-to-temp-buffer (help-buffer) |
1241 |
(save-excursion |
(save-excursion |
1242 |
(set-buffer standard-output) |
(set-buffer standard-output) |
1243 |
(dolist (a attrs) |
(dolist (f face) |
1244 |
(let ((attr (face-attribute face (car a) frame))) |
(insert "Face: " (symbol-name f)) |
1245 |
(insert (make-string (- max-width (length (cdr a))) ?\ ) |
(if (not (facep f)) |
1246 |
(cdr a) ": " (format "%s" attr) "\n"))) |
(insert " undefined face.\n") |
1247 |
(insert "\nDocumentation:\n\n" |
(let ((customize-label "customize this face")) |
1248 |
(or (face-documentation face) |
(princ (concat " (" customize-label ")\n")) |
1249 |
"not documented as a face.")) |
(insert "Documentation: " |
1250 |
(let ((customize-label "customize")) |
(or (face-documentation f) |
1251 |
(terpri) |
"not documented as a face.") |
1252 |
(terpri) |
"\n\n") |
1253 |
(princ (concat "You can " customize-label " this face.")) |
(with-current-buffer standard-output |
1254 |
(with-current-buffer standard-output |
(save-excursion |
1255 |
(save-excursion |
(re-search-backward |
1256 |
(re-search-backward |
(concat "\\(" customize-label "\\)") nil t) |
1257 |
(concat "\\(" customize-label "\\)") nil t) |
(help-xref-button 1 'help-customize-face f))) |
1258 |
(help-xref-button 1 'help-customize-face face))))) |
(dolist (a attrs) |
1259 |
|
(let ((attr (face-attribute f (car a) frame))) |
1260 |
|
(insert (make-string (- max-width (length (cdr a))) ?\ ) |
1261 |
|
(cdr a) ": " (format "%s" attr) "\n"))))) |
1262 |
|
(terpri))) |
1263 |
(print-help-return-message)))) |
(print-help-return-message)))) |
1264 |
|
|
1265 |
|
|