Commit | Line | Data |
---|---|---|
d543e20b PA |
1 | ;;; cus-face.el -- XEmacs specific custom support. |
2 | ;; | |
3 | ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. | |
4 | ;; | |
5 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
6 | ;; Keywords: help, faces | |
7 | ;; Version: 1.71 | |
8 | ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | |
9 | ||
10 | ;;; Commentary: | |
11 | ;; | |
12 | ;; See `custom.el'. | |
13 | ||
14 | ;;; Code: | |
15 | ||
16 | (require 'custom) | |
17 | ||
18 | (eval-and-compile (require 'cl)) | |
19 | ||
20 | ;;; Compatibility. | |
21 | ||
22 | (if (string-match "XEmacs" emacs-version) | |
23 | (defun custom-face-background (face &optional frame) | |
24 | ;; Specifiers suck! | |
25 | "Return the background color name of face FACE, or nil if unspecified." | |
26 | (color-instance-name (specifier-instance (face-background face) frame))) | |
27 | (defalias 'custom-face-background 'face-background)) | |
28 | ||
29 | (if (string-match "XEmacs" emacs-version) | |
30 | (defun custom-face-foreground (face &optional frame) | |
31 | ;; Specifiers suck! | |
32 | "Return the background color name of face FACE, or nil if unspecified." | |
33 | (color-instance-name (specifier-instance (face-foreground face) frame))) | |
34 | (defalias 'custom-face-foreground 'face-foreground)) | |
35 | ||
36 | (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version) | |
37 | 'face-font-name | |
38 | 'face-font)) | |
39 | ||
40 | (eval-and-compile | |
41 | (unless (fboundp 'frame-property) | |
42 | ;; XEmacs function missing in Emacs 19.34. | |
43 | (defun frame-property (frame property &optional default) | |
44 | "Return FRAME's value for property PROPERTY." | |
45 | (or (cdr (assq property (frame-parameters frame))) | |
46 | default))) | |
47 | ||
48 | (unless (fboundp 'face-doc-string) | |
49 | ;; XEmacs function missing in Emacs. | |
50 | (defun face-doc-string (face) | |
51 | "Get the documentation string for FACE." | |
52 | (get face 'face-doc-string))) | |
53 | ||
54 | (unless (fboundp 'set-face-doc-string) | |
55 | ;; XEmacs function missing in Emacs. | |
56 | (defun set-face-doc-string (face string) | |
57 | "Set the documentation string for FACE to STRING." | |
58 | (put face 'face-doc-string string))) | |
59 | ||
60 | (when (and (not (fboundp 'set-face-stipple)) | |
61 | (fboundp 'set-face-background-pixmap)) | |
62 | ;; Emacs function missing in XEmacs 19.15. | |
63 | (defun set-face-stipple (face pixmap &optional frame) | |
64 | ;; Written by Kyle Jones. | |
65 | "Change the stipple pixmap of face FACE to PIXMAP. | |
66 | PIXMAP should be a string, the name of a file of pixmap data. | |
67 | The directories listed in the `x-bitmap-file-path' variable are searched. | |
68 | ||
69 | Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT DATA) | |
70 | where WIDTH and HEIGHT are the size in pixels, | |
71 | and DATA is a string, containing the raw bits of the bitmap. | |
72 | ||
73 | If the optional FRAME argument is provided, change only | |
74 | in that frame; otherwise change each frame." | |
75 | (while (not (find-face face)) | |
76 | (setq face (signal 'wrong-type-argument (list 'facep face)))) | |
77 | (while (cond ((stringp pixmap) | |
78 | (unless (file-readable-p pixmap) | |
79 | (setq pixmap (vector 'xbm ':file pixmap))) | |
80 | nil) | |
81 | ((and (consp pixmap) (= (length pixmap) 3)) | |
82 | (setq pixmap (vector 'xbm ':data pixmap)) | |
83 | nil) | |
84 | (t t)) | |
85 | (setq pixmap (signal 'wrong-type-argument | |
86 | (list 'stipple-pixmap-p pixmap)))) | |
87 | (while (and frame (not (framep frame))) | |
88 | (setq frame (signal 'wrong-type-argument (list 'framep frame)))) | |
89 | (set-face-background-pixmap face pixmap frame)))) | |
90 | ||
91 | (unless (fboundp 'x-color-values) | |
92 | ;; Emacs function missing in XEmacs 19.14. | |
93 | (defun x-color-values (color &optional frame) | |
94 | "Return a description of the color named COLOR on frame FRAME. | |
95 | The value is a list of integer RGB values--(RED GREEN BLUE). | |
96 | These values appear to range from 0 to 65280 or 65535, depending | |
97 | on the system; white is (65280 65280 65280) or (65535 65535 65535). | |
98 | If FRAME is omitted or nil, use the selected frame." | |
99 | (color-instance-rgb-components (make-color-instance color)))) | |
100 | ||
101 | ;; XEmacs and Emacs have different definitions of `facep'. | |
102 | ;; The Emacs definition is the useful one, so emulate that. | |
103 | (cond ((not (fboundp 'facep)) | |
104 | (defun custom-facep (face) | |
105 | "No faces" | |
106 | nil)) | |
107 | ((string-match "XEmacs" emacs-version) | |
108 | (defalias 'custom-facep 'find-face)) | |
109 | (t | |
110 | (defalias 'custom-facep 'facep))) | |
111 | ||
112 | (unless (fboundp 'make-empty-face) | |
113 | ;; This should be moved to `faces.el'. | |
114 | (if (string-match "XEmacs" emacs-version) | |
115 | ;; Give up for old XEmacs pre 19.15/20.1. | |
116 | (defalias 'make-empty-face 'make-face) | |
117 | ;; Define for Emacs pre 19.35. | |
118 | (defun make-empty-face (name) | |
119 | "Define a new FACE on all frames, ignoring X resources." | |
120 | (interactive "SMake face: ") | |
121 | (or (internal-find-face name) | |
122 | (let ((face (make-vector 8 nil))) | |
123 | (aset face 0 'face) | |
124 | (aset face 1 name) | |
125 | (let* ((frames (frame-list)) | |
126 | (inhibit-quit t) | |
127 | (id (internal-next-face-id))) | |
128 | (make-face-internal id) | |
129 | (aset face 2 id) | |
130 | (while frames | |
131 | (set-frame-face-alist (car frames) | |
132 | (cons (cons name (copy-sequence face)) | |
133 | (frame-face-alist (car frames)))) | |
134 | (setq frames (cdr frames))) | |
135 | (setq global-face-data (cons (cons name face) global-face-data))) | |
136 | ;; add to menu | |
137 | (if (fboundp 'facemenu-add-new-face) | |
138 | (facemenu-add-new-face name)) | |
139 | face)) | |
140 | name))) | |
141 | ||
142 | (defcustom initialize-face-resources t | |
143 | "If non nil, allow X resources to initialize face properties. | |
144 | This only affects faces declared with `defface', and only NT or X11 frames." | |
145 | :group 'customize | |
146 | :type 'boolean) | |
147 | ||
148 | (cond ((fboundp 'initialize-face-resources) | |
149 | ;; Already bound, do nothing. | |
150 | ) | |
151 | ((fboundp 'make-face-x-resource-internal) | |
152 | ;; Emacs or new XEmacs. | |
153 | (defun initialize-face-resources (face &optional frame) | |
154 | "Initialize face according to the X11 resources. | |
155 | This might overwrite existing face properties. | |
156 | Does nothing when the variable initialize-face-resources is nil." | |
157 | (when initialize-face-resources | |
158 | (make-face-x-resource-internal face frame t)))) | |
159 | (t | |
160 | ;; Too hard to do right on XEmacs. | |
161 | (defalias 'initialize-face-resources 'ignore))) | |
162 | ||
163 | ;;(if (string-match "XEmacs" emacs-version) | |
164 | ;; ;; Xemacs. | |
165 | ;; (defun custom-invert-face (face &optional frame) | |
166 | ;; "Swap the foreground and background colors of face FACE. | |
167 | ;;If the colors are not specified in the face, use the default colors." | |
168 | ;; (interactive (list (read-face-name "Reverse face: "))) | |
169 | ;; (let ((fg (color-name (face-foreground face frame) frame)) | |
170 | ;; (bg (color-name (face-background face frame) frame))) | |
171 | ;; (set-face-foreground face bg frame) | |
172 | ;; (set-face-background face fg frame))) | |
173 | ;; ;; Emacs. | |
174 | ;; (defun custom-invert-face (face &optional frame) | |
175 | ;; "Swap the foreground and background colors of face FACE. | |
176 | ;;If the colors are not specified in the face, use the default colors." | |
177 | ;; (interactive (list (read-face-name "Reverse face: "))) | |
178 | ;; (let ((fg (or (face-foreground face frame) | |
179 | ;; (face-foreground 'default frame) | |
180 | ;; (frame-property (or frame (selected-frame)) | |
181 | ;; 'foreground-color) | |
182 | ;; "black")) | |
183 | ;; (bg (or (face-background face frame) | |
184 | ;; (face-background 'default frame) | |
185 | ;; (frame-property (or frame (selected-frame)) | |
186 | ;; 'background-color) | |
187 | ;; "white"))) | |
188 | ;; (set-face-foreground face bg frame) | |
189 | ;; (set-face-background face fg frame)))) | |
190 | ||
191 | (defcustom custom-background-mode nil | |
192 | "The brightness of the background. | |
193 | Set this to the symbol dark if your background color is dark, light if | |
194 | your background is light, or nil (default) if you want Emacs to | |
195 | examine the brightness for you." | |
196 | :group 'customize | |
197 | :type '(choice (choice-item dark) | |
198 | (choice-item light) | |
199 | (choice-item :tag "default" nil))) | |
200 | ||
201 | (defun custom-background-mode (frame) | |
202 | "Kludge to detect background mode for FRAME." | |
203 | (let* ((bg-resource | |
204 | (condition-case () | |
205 | (x-get-resource ".backgroundMode" "BackgroundMode" 'string) | |
206 | (error nil))) | |
207 | color | |
208 | (mode (cond (bg-resource | |
209 | (intern (downcase bg-resource))) | |
210 | ((and (setq color (condition-case () | |
211 | (or (frame-property | |
212 | frame | |
213 | 'background-color) | |
214 | (custom-face-background | |
215 | 'default)) | |
216 | (error nil))) | |
217 | (or (string-match "XEmacs" emacs-version) | |
218 | window-system) | |
219 | (< (apply '+ (x-color-values color)) | |
220 | (/ (apply '+ (x-color-values "white")) | |
221 | 3))) | |
222 | 'dark) | |
223 | (t 'light)))) | |
224 | (modify-frame-parameters frame (list (cons 'background-mode mode))) | |
225 | mode)) | |
226 | ||
227 | (eval-and-compile | |
228 | (if (string-match "XEmacs" emacs-version) | |
229 | ;; XEmacs. | |
230 | (defun custom-extract-frame-properties (frame) | |
231 | "Return a plist with the frame properties of FRAME used by custom." | |
232 | (list 'type (device-type (frame-device frame)) | |
233 | 'class (device-class (frame-device frame)) | |
234 | 'background (or custom-background-mode | |
235 | (frame-property frame | |
236 | 'background-mode) | |
237 | (custom-background-mode frame)))) | |
238 | ;; Emacs. | |
239 | (defun custom-extract-frame-properties (frame) | |
240 | "Return a plist with the frame properties of FRAME used by custom." | |
241 | (list 'type window-system | |
242 | 'class (frame-property frame 'display-type) | |
243 | 'background (or custom-background-mode | |
244 | (frame-property frame 'background-mode) | |
245 | (custom-background-mode frame)))))) | |
246 | ||
247 | ;;; Declaring a face. | |
248 | ||
249 | ;;;###autoload | |
250 | (defun custom-declare-face (face spec doc &rest args) | |
251 | "Like `defface', but FACE is evaluated as a normal argument." | |
252 | (when (fboundp 'load-gc) | |
253 | ;; This should be allowed, somehow. | |
254 | (error "Attempt to declare a face during dump")) | |
255 | (unless (get face 'factory-face) | |
256 | (put face 'factory-face spec) | |
257 | (when (fboundp 'facep) | |
258 | (unless (custom-facep face) | |
259 | ;; If the user has already created the face, respect that. | |
260 | (let ((value (or (get face 'saved-face) spec)) | |
261 | (frames (custom-relevant-frames)) | |
262 | frame) | |
263 | ;; Create global face. | |
264 | (make-empty-face face) | |
265 | (custom-face-display-set face value) | |
266 | ;; Create frame local faces | |
267 | (while frames | |
268 | (setq frame (car frames) | |
269 | frames (cdr frames)) | |
270 | (custom-face-display-set face value frame)) | |
271 | (initialize-face-resources face)))) | |
272 | (when (and doc (null (face-doc-string face))) | |
273 | (set-face-doc-string face doc)) | |
274 | (custom-handle-all-keywords face args 'custom-face) | |
275 | (run-hooks 'custom-define-hook)) | |
276 | face) | |
277 | ||
278 | ;;; Font Attributes. | |
279 | ||
280 | (defconst custom-face-attributes | |
281 | '((:bold (toggle :format "Bold: %[%v%]\n" | |
282 | :help-echo "Control whether a bold font should be used.") | |
283 | custom-set-face-bold | |
284 | custom-face-bold) | |
285 | (:italic (toggle :format "Italic: %[%v%]\n" | |
286 | :help-echo "\ | |
287 | Control whether an italic font should be used.") | |
288 | custom-set-face-italic | |
289 | custom-face-italic) | |
290 | (:underline (toggle :format "Underline: %[%v%]\n" | |
291 | :help-echo "\ | |
292 | Control whether the text should be underlined.") | |
293 | set-face-underline-p | |
294 | face-underline-p) | |
295 | (:foreground (color :tag "Foreground" | |
296 | :value "black" | |
297 | :help-echo "Set foreground color.") | |
298 | set-face-foreground | |
299 | custom-face-foreground) | |
300 | (:background (color :tag "Background" | |
301 | :value "white" | |
302 | :help-echo "Set background color.") | |
303 | set-face-background | |
304 | custom-face-background) | |
305 | ;; (:invert (const :format "Invert Face\n" | |
306 | ;; :sibling-args (:help-echo " | |
307 | ;;Reverse the foreground and background color. | |
308 | ;;If you haven't specified them for the face, the default colors will be used.") | |
309 | ;; t) | |
310 | ;; (lambda (face value &optional frame) | |
311 | ;; ;; We don't use VALUE. | |
312 | ;; (custom-invert-face face frame))) | |
313 | (:stipple (editable-field :format "Stipple: %v" | |
314 | :help-echo "Name of background bitmap file.") | |
315 | set-face-stipple custom-face-stipple)) | |
316 | "Alist of face attributes. | |
317 | ||
318 | The elements are of the form (KEY TYPE SET GET) where KEY is a symbol | |
319 | identifying the attribute, TYPE is a widget type for editing the | |
320 | attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. | |
321 | ||
322 | The SET function should take three arguments, the face to modify, the | |
323 | value of the attribute, and optionally the frame where the face should | |
324 | be changed. | |
325 | ||
326 | The GET function should take two arguments, the face to examine, and | |
327 | optonally the frame where the face should be examined.") | |
328 | ||
329 | (defun custom-face-attributes-set (face frame &rest atts) | |
330 | "For FACE on FRAME set the attributes [KEYWORD VALUE].... | |
331 | Each keyword should be listed in `custom-face-attributes'. | |
332 | ||
333 | If FRAME is nil, set the default face." | |
334 | (while atts | |
335 | (let* ((name (nth 0 atts)) | |
336 | (value (nth 1 atts)) | |
337 | (fun (nth 2 (assq name custom-face-attributes)))) | |
338 | (setq atts (cdr (cdr atts))) | |
339 | (condition-case nil | |
340 | (funcall fun face value frame) | |
341 | (error nil))))) | |
342 | ||
343 | (defun custom-face-attributes-get (face frame) | |
344 | "For FACE on FRAME get the attributes [KEYWORD VALUE].... | |
345 | Each keyword should be listed in `custom-face-attributes'. | |
346 | ||
347 | If FRAME is nil, use the default face." | |
348 | (condition-case nil | |
349 | ;; Attempt to get `font.el' from w3. | |
350 | (require 'font) | |
351 | (error nil)) | |
352 | (let ((atts custom-face-attributes) | |
353 | att result get) | |
354 | (while atts | |
355 | (setq att (car atts) | |
356 | atts (cdr atts) | |
357 | get (nth 3 att)) | |
358 | (when get | |
359 | (let ((answer (funcall get face frame))) | |
360 | (unless (equal answer (funcall get 'default frame)) | |
361 | (when (widget-apply (nth 1 att) :match answer) | |
362 | (setq result (cons (nth 0 att) (cons answer result)))))))) | |
363 | result)) | |
364 | ||
365 | (defun custom-set-face-bold (face value &optional frame) | |
366 | "Set the bold property of FACE to VALUE." | |
367 | (if value | |
368 | (make-face-bold face frame) | |
369 | (make-face-unbold face frame))) | |
370 | ||
371 | (defun custom-face-bold (face &rest args) | |
372 | "Return non-nil if the font of FACE is bold." | |
373 | (let* ((font (apply 'custom-face-font-name face args)) | |
374 | (fontobj (font-create-object font))) | |
375 | (font-bold-p fontobj))) | |
376 | ||
377 | (defun custom-set-face-italic (face value &optional frame) | |
378 | "Set the italic property of FACE to VALUE." | |
379 | (if value | |
380 | (make-face-italic face frame) | |
381 | (make-face-unitalic face frame))) | |
382 | ||
383 | (defun custom-face-italic (face &rest args) | |
384 | "Return non-nil if the font of FACE is italic." | |
385 | (let* ((font (apply 'custom-face-font-name face args)) | |
386 | (fontobj (font-create-object font))) | |
387 | (font-italic-p fontobj))) | |
388 | ||
389 | (defun custom-face-stipple (face &rest args) | |
390 | "Return the name of the stipple file used for FACE." | |
391 | (if (string-match "XEmacs" emacs-version) | |
392 | (let ((image (apply 'specifier-instance | |
393 | (face-background-pixmap face) args))) | |
394 | (when image | |
395 | (image-instance-file-name image))) | |
396 | (apply 'face-stipple face args))) | |
397 | ||
398 | (when (string-match "XEmacs" emacs-version) | |
399 | ;; Support for special XEmacs font attributes. | |
400 | (autoload 'font-create-object "font" nil) | |
401 | ||
402 | (defun custom-set-face-font-size (face size &rest args) | |
403 | "Set the font of FACE to SIZE" | |
404 | (let* ((font (apply 'custom-face-font-name face args)) | |
405 | (fontobj (font-create-object font))) | |
406 | (set-font-size fontobj size) | |
407 | (apply 'font-set-face-font face fontobj args))) | |
408 | ||
409 | (defun custom-face-font-size (face &rest args) | |
410 | "Return the size of the font of FACE as a string." | |
411 | (let* ((font (apply 'custom-face-font-name face args)) | |
412 | (fontobj (font-create-object font))) | |
413 | (format "%d" (font-size fontobj)))) | |
414 | ||
415 | (defun custom-set-face-font-family (face family &rest args) | |
416 | "Set the font of FACE to FAMILY." | |
417 | (let* ((font (apply 'custom-face-font-name face args)) | |
418 | (fontobj (font-create-object font))) | |
419 | (set-font-family fontobj family) | |
420 | (apply 'font-set-face-font face fontobj args))) | |
421 | ||
422 | (defun custom-face-font-family (face &rest args) | |
423 | "Return the name of the font family of FACE." | |
424 | (let* ((font (apply 'custom-face-font-name face args)) | |
425 | (fontobj (font-create-object font))) | |
426 | (font-family fontobj))) | |
427 | ||
428 | (nconc custom-face-attributes | |
429 | '((:family (editable-field :format "Font Family: %v" | |
430 | :help-echo "\ | |
431 | Name of font family to use (e.g. times).") | |
432 | custom-set-face-font-family | |
433 | custom-face-font-family) | |
434 | (:size (editable-field :format "Size: %v" | |
435 | :help-echo "\ | |
436 | Text size (e.g. 9pt or 2mm).") | |
437 | custom-set-face-font-size | |
438 | custom-face-font-size)))) | |
439 | ||
440 | ;;; Frames. | |
441 | ||
442 | (defun custom-face-display-set (face spec &optional frame) | |
443 | "Set FACE to the attributes to the first matching entry in SPEC. | |
444 | Iff optional FRAME is non-nil, set it for that frame only. | |
445 | See `defface' for information about SPEC." | |
446 | (when (fboundp 'make-face) | |
447 | (while spec | |
448 | (let* ((entry (car spec)) | |
449 | (display (nth 0 entry)) | |
450 | (atts (nth 1 entry))) | |
451 | (setq spec (cdr spec)) | |
452 | (when (custom-display-match-frame display frame) | |
453 | ;; Avoid creating frame local duplicates of the global face. | |
454 | (unless (and frame (eq display (get face 'custom-face-display))) | |
455 | (apply 'custom-face-attributes-set face frame atts)) | |
456 | (unless frame | |
457 | (put face 'custom-face-display display)) | |
458 | (setq spec nil)))))) | |
459 | ||
460 | (defvar custom-default-frame-properties nil | |
461 | "The frame properties used for the global faces. | |
462 | Frames who doesn't match these propertiess should have frame local faces. | |
463 | The value should be nil, if uninitialized, or a plist otherwise. | |
464 | See `defface' for a list of valid keys and values for the plist.") | |
465 | ||
466 | (defun custom-get-frame-properties (&optional frame) | |
467 | "Return a plist with the frame properties of FRAME used by custom. | |
468 | If FRAME is nil, return the default frame properties." | |
469 | (cond (frame | |
470 | ;; Try to get from cache. | |
471 | (let ((cache (frame-property frame 'custom-properties))) | |
472 | (unless cache | |
473 | ;; Oh well, get it then. | |
474 | (setq cache (custom-extract-frame-properties frame)) | |
475 | ;; and cache it... | |
476 | (modify-frame-parameters frame | |
477 | (list (cons 'custom-properties cache)))) | |
478 | cache)) | |
479 | (custom-default-frame-properties) | |
480 | (t | |
481 | (setq custom-default-frame-properties | |
482 | (custom-extract-frame-properties (selected-frame)))))) | |
483 | ||
484 | (defun custom-display-match-frame (display frame) | |
485 | "Non-nil iff DISPLAY matches FRAME. | |
486 | If FRAME is nil, the current FRAME is used." | |
487 | ;; This is a kludge to get started, we really should use specifiers! | |
488 | (if (eq display t) | |
489 | t | |
490 | (let* ((props (custom-get-frame-properties frame)) | |
491 | (type (plist-get props 'type)) | |
492 | (class (plist-get props 'class)) | |
493 | (background (plist-get props 'background)) | |
494 | (match t) | |
495 | (entries display) | |
496 | entry req options) | |
497 | (while (and entries match) | |
498 | (setq entry (car entries) | |
499 | entries (cdr entries) | |
500 | req (car entry) | |
501 | options (cdr entry) | |
502 | match (cond ((eq req 'type) | |
503 | (memq type options)) | |
504 | ((eq req 'class) | |
505 | (memq class options)) | |
506 | ((eq req 'background) | |
507 | (memq background options)) | |
508 | (t | |
509 | (error "Unknown req `%S' with options `%S'" | |
510 | req options))))) | |
511 | match))) | |
512 | ||
513 | (defun custom-relevant-frames () | |
514 | "List of frames whose custom properties differ from the default." | |
515 | (let ((relevant nil) | |
516 | (default (custom-get-frame-properties)) | |
517 | (frames (frame-list)) | |
518 | frame) | |
519 | (while frames | |
520 | (setq frame (car frames) | |
521 | frames (cdr frames)) | |
522 | (unless (equal default (custom-get-frame-properties frame)) | |
523 | (push frame relevant))) | |
524 | relevant)) | |
525 | ||
526 | (defun custom-initialize-faces (&optional frame) | |
527 | "Initialize all custom faces for FRAME. | |
528 | If FRAME is nil or omitted, initialize them for all frames." | |
529 | (mapcar (lambda (symbol) | |
530 | (let ((spec (or (get symbol 'saved-face) | |
531 | (get symbol 'factory-face)))) | |
532 | (when spec | |
533 | (custom-face-display-set symbol spec frame) | |
534 | (initialize-face-resources symbol frame)))) | |
535 | (face-list))) | |
536 | ||
537 | (defun custom-initialize-frame (&optional frame) | |
538 | "Initialize local faces for FRAME if necessary. | |
539 | If FRAME is missing or nil, the first member of (frame-list) is used." | |
540 | (unless frame | |
541 | (setq frame (car (frame-list)))) | |
542 | (unless (equal (custom-get-frame-properties) | |
543 | (custom-get-frame-properties frame)) | |
544 | (custom-initialize-faces frame))) | |
545 | ||
546 | ;; Enable. This should go away when bundled with Emacs. | |
547 | (unless (string-match "XEmacs" emacs-version) | |
548 | (add-hook 'after-make-frame-hook 'custom-initialize-frame)) | |
549 | ||
550 | ;;; Initializing. | |
551 | ||
552 | (and (fboundp 'make-face) | |
553 | (make-face 'custom-face-empty)) | |
554 | ||
555 | ;;;###autoload | |
556 | (defun custom-set-faces (&rest args) | |
557 | "Initialize faces according to user preferences. | |
558 | The arguments should be a list where each entry has the form: | |
559 | ||
560 | (FACE SPEC [NOW]) | |
561 | ||
562 | SPEC will be stored as the saved value for FACE. If NOW is present | |
563 | and non-nil, FACE will also be created according to SPEC. | |
564 | ||
565 | See `defface' for the format of SPEC." | |
566 | (while args | |
567 | (let ((entry (car args))) | |
568 | (if (listp entry) | |
569 | (let ((face (nth 0 entry)) | |
570 | (spec (nth 1 entry)) | |
571 | (now (nth 2 entry))) | |
572 | (put face 'saved-face spec) | |
573 | (when now | |
574 | (put face 'force-face t)) | |
575 | (when (or now (custom-facep face)) | |
576 | (when (fboundp 'copy-face) | |
577 | (copy-face 'custom-face-empty face)) | |
578 | (custom-face-display-set face spec)) | |
579 | (setq args (cdr args))) | |
580 | ;; Old format, a plist of FACE SPEC pairs. | |
581 | (let ((face (nth 0 args)) | |
582 | (spec (nth 1 args))) | |
583 | (put face 'saved-face spec)) | |
584 | (setq args (cdr (cdr args))))))) | |
585 | ||
586 | ;;; The End. | |
587 | ||
588 | (provide 'cus-face) | |
589 | ||
590 | ;; cus-face.el ends here |