Commit | Line | Data |
---|---|---|
33813370 RT |
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
2 | ;;; Listing faces. | |
3 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
4 | ||
5 | (defconst list-faces-sample-text | |
6 | "abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ" | |
7 | "Text string to display as the sample text for `list-faces-display'.") | |
8 | ||
9 | ||
10 | ;; The name list-faces would be more consistent, but let's avoid a | |
11 | ;; conflict with Lucid, which uses that name differently. | |
12 | ||
13 | (defvar help-xref-stack) | |
14 | (defun list-faces-display (&optional regexp) | |
15 | "List all faces, using the same sample text in each. | |
16 | The sample text is a string that comes from the variable | |
17 | `list-faces-sample-text'. | |
18 | ||
19 | If REGEXP is non-nil, list only those faces with names matching | |
20 | this regular expression. When called interactively with a prefix | |
21 | arg, prompt for a regular expression." | |
22 | (interactive (list (and current-prefix-arg | |
23 | (read-regexp "List faces matching regexp")))) | |
24 | (let ((all-faces (zerop (length regexp))) | |
25 | (frame (selected-frame)) | |
26 | (max-length 0) | |
27 | faces line-format | |
28 | disp-frame window face-name) | |
29 | ;; We filter and take the max length in one pass | |
30 | (setq faces | |
31 | (delq nil | |
32 | (mapcar (lambda (f) | |
33 | (let ((s (symbol-name f))) | |
34 | (when (or all-faces (string-match-p regexp s)) | |
35 | (setq max-length (max (length s) max-length)) | |
36 | f))) | |
37 | (sort (face-list) #'string-lessp)))) | |
38 | (unless faces | |
39 | (error "No faces matching \"%s\"" regexp)) | |
40 | (setq max-length (1+ max-length) | |
41 | line-format (format "%%-%ds" max-length)) | |
42 | (with-help-window "*Faces*" | |
43 | (with-current-buffer standard-output | |
44 | (setq truncate-lines t) | |
45 | (insert | |
46 | (substitute-command-keys | |
47 | (concat | |
48 | "\\<help-mode-map>Use " | |
49 | (if (display-mouse-p) "\\[help-follow-mouse] or ") | |
50 | "\\[help-follow] on a face name to customize it\n" | |
51 | "or on its sample text for a description of the face.\n\n"))) | |
52 | (setq help-xref-stack nil) | |
53 | (dolist (face faces) | |
54 | (setq face-name (symbol-name face)) | |
55 | (insert (format line-format face-name)) | |
56 | ;; Hyperlink to a customization buffer for the face. Using | |
57 | ;; the help xref mechanism may not be the best way. | |
58 | (save-excursion | |
59 | (save-match-data | |
60 | (search-backward face-name) | |
61 | (setq help-xref-stack-item `(list-faces-display ,regexp)) | |
62 | (help-xref-button 0 'help-customize-face face))) | |
63 | (let ((beg (point)) | |
64 | (line-beg (line-beginning-position))) | |
65 | (insert list-faces-sample-text) | |
66 | ;; Hyperlink to a help buffer for the face. | |
67 | (save-excursion | |
68 | (save-match-data | |
69 | (search-backward list-faces-sample-text) | |
70 | (help-xref-button 0 'help-face face))) | |
71 | (insert "\n") | |
72 | (put-text-property beg (1- (point)) 'face face) | |
73 | ;; Make all face commands default to the proper face | |
74 | ;; anywhere in the line. | |
75 | (put-text-property line-beg (1- (point)) 'read-face-name face) | |
76 | ;; If the sample text has multiple lines, line up all of them. | |
77 | (goto-char beg) | |
78 | (forward-line 1) | |
79 | (while (not (eobp)) | |
80 | (insert-char ?\s max-length) | |
81 | (forward-line 1)))) | |
82 | (goto-char (point-min)))) | |
83 | ;; If the *Faces* buffer appears in a different frame, | |
84 | ;; copy all the face definitions from FRAME, | |
85 | ;; so that the display will reflect the frame that was selected. | |
86 | (setq window (get-buffer-window (get-buffer "*Faces*") t)) | |
87 | (setq disp-frame (if window (window-frame window) | |
88 | (car (frame-list)))) | |
89 | (or (eq frame disp-frame) | |
90 | (dolist (face (face-list)) | |
91 | (copy-face face face frame disp-frame))))) | |
92 | ||
93 | ||
94 | (defun describe-face (face &optional frame) | |
95 | "Display the properties of face FACE on FRAME. | |
96 | Interactively, FACE defaults to the faces of the character after point | |
97 | and FRAME defaults to the selected frame. | |
98 | ||
99 | If the optional argument FRAME is given, report on face FACE in that frame. | |
100 | If FRAME is t, report on the defaults for face FACE (for new frames). | |
101 | If FRAME is omitted or nil, use the selected frame." | |
102 | (interactive (list (read-face-name "Describe face" | |
103 | (or (face-at-point t) 'default) | |
104 | t))) | |
105 | (let* ((attrs '((:family . "Family") | |
106 | (:foundry . "Foundry") | |
107 | (:width . "Width") | |
108 | (:height . "Height") | |
109 | (:weight . "Weight") | |
110 | (:slant . "Slant") | |
111 | (:foreground . "Foreground") | |
112 | (:distant-foreground . "DistantForeground") | |
113 | (:background . "Background") | |
114 | (:underline . "Underline") | |
115 | (:overline . "Overline") | |
116 | (:strike-through . "Strike-through") | |
117 | (:box . "Box") | |
118 | (:inverse-video . "Inverse") | |
119 | (:stipple . "Stipple") | |
120 | (:font . "Font") | |
121 | (:fontset . "Fontset") | |
122 | (:inherit . "Inherit"))) | |
123 | (max-width (apply #'max (mapcar #'(lambda (x) (length (cdr x))) | |
124 | attrs)))) | |
125 | (help-setup-xref (list #'describe-face face) | |
126 | (called-interactively-p 'interactive)) | |
127 | (unless face | |
128 | (setq face 'default)) | |
129 | (if (not (listp face)) | |
130 | (setq face (list face))) | |
131 | (with-help-window (help-buffer) | |
132 | (with-current-buffer standard-output | |
133 | (dolist (f face) | |
134 | (if (stringp f) (setq f (intern f))) | |
135 | ;; We may get called for anonymous faces (i.e., faces | |
136 | ;; expressed using prop-value plists). Those can't be | |
137 | ;; usefully customized, so ignore them. | |
138 | (when (symbolp f) | |
139 | (insert "Face: " (symbol-name f)) | |
140 | (if (not (facep f)) | |
141 | (insert " undefined face.\n") | |
142 | (let ((customize-label "customize this face") | |
143 | file-name) | |
144 | (insert (concat " (" (propertize "sample" 'font-lock-face f) ")")) | |
145 | (princ (concat " (" customize-label ")\n")) | |
146 | ;; FIXME not sure how much of this belongs here, and | |
147 | ;; how much in `face-documentation'. The latter is | |
148 | ;; not used much, but needs to return nil for | |
149 | ;; undocumented faces. | |
150 | (let ((alias (get f 'face-alias)) | |
151 | (face f) | |
152 | obsolete) | |
153 | (when alias | |
154 | (setq face alias) | |
155 | (insert | |
156 | (format "\n %s is an alias for the face `%s'.\n%s" | |
157 | f alias | |
158 | (if (setq obsolete (get f 'obsolete-face)) | |
159 | (format " This face is obsolete%s; use `%s' instead.\n" | |
160 | (if (stringp obsolete) | |
161 | (format " since %s" obsolete) | |
162 | "") | |
163 | alias) | |
164 | "")))) | |
165 | (insert "\nDocumentation:\n" | |
166 | (or (face-documentation face) | |
167 | "Not documented as a face.") | |
168 | "\n\n")) | |
169 | (with-current-buffer standard-output | |
170 | (save-excursion | |
171 | (re-search-backward | |
172 | (concat "\\(" customize-label "\\)") nil t) | |
173 | (help-xref-button 1 'help-customize-face f))) | |
174 | (setq file-name (find-lisp-object-file-name f 'defface)) | |
175 | (when file-name | |
176 | (princ "Defined in `") | |
177 | (princ (file-name-nondirectory file-name)) | |
178 | (princ "'") | |
179 | ;; Make a hyperlink to the library. | |
180 | (save-excursion | |
181 | (re-search-backward "`\\([^`']+\\)'" nil t) | |
182 | (help-xref-button 1 'help-face-def f file-name)) | |
183 | (princ ".") | |
184 | (terpri) | |
185 | (terpri)) | |
186 | (dolist (a attrs) | |
187 | (let ((attr (face-attribute f (car a) frame))) | |
188 | (insert (make-string (- max-width (length (cdr a))) ?\s) | |
189 | (cdr a) ": " (format "%s" attr)) | |
190 | (if (and (eq (car a) :inherit) | |
191 | (not (eq attr 'unspecified))) | |
192 | ;; Make a hyperlink to the parent face. | |
193 | (save-excursion | |
194 | (re-search-backward ": \\([^:]+\\)" nil t) | |
195 | (help-xref-button 1 'help-face attr))) | |
196 | (insert "\n"))))) | |
197 | (terpri))))))) |