Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 195:a2f645c6b9f8 r20-3b24

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b24
author cvs
date Mon, 13 Aug 2007 09:59:05 +0200
parents f53b5ca2e663
children acd284d43ca1
comparison
equal deleted inserted replaced
194:2947057885e5 195:a2f645c6b9f8
1 ;;; cus-face.el -- XEmacs specific custom support. 1 ;;; cus-face.el -- Support for Custom faces.
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4 ;; 4 ;;
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
6 ;; Keywords: help, faces 7 ;; Keywords: help, faces
7 ;; Version: 1.9960 8 ;; Version: 1.9960-x
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 10
10 ;;; Commentary: 11 ;;; Commentary:
11 ;; 12 ;;
12 ;; See `custom.el'. 13 ;; See `custom.el'.
13 14
15 ;; This file should probably be dissolved, and code moved to faces.el,
16 ;; like Stallman did.
17
14 ;;; Code: 18 ;;; Code:
15 19
16 (require 'custom) 20 (require 'custom)
17 21
18 (eval-when-compile (require 'cl)) 22 ;; To elude the warnings for font functions.
19 23 (eval-when-compile
20 ;;; Compatibility. 24 (require 'font))
21 25
22 (if (string-match "XEmacs" emacs-version) 26 ;;;###autoload
23 (defun custom-face-background (face &optional frame) 27 (defcustom frame-background-mode nil
24 ;; Specifiers suck! 28 "*The brightness of the background.
25 "Return the background color name of face FACE, or nil if unspecified." 29 Set this to the symbol dark if your background color is dark, light if
26 (color-instance-name (specifier-instance (face-background face) frame))) 30 your background is light, or nil (default) if you want Emacs to
27 (defalias 'custom-face-background 'face-background)) 31 examine the brightness for you."
28 32 :group 'faces
29 (if (string-match "XEmacs" emacs-version) 33 :type '(choice (choice-item dark)
30 (defun custom-face-foreground (face &optional frame) 34 (choice-item light)
31 ;; Specifiers suck! 35 (choice-item :tag "Auto" nil)))
32 "Return the background color name of face FACE, or nil if unspecified." 36
33 (color-instance-name (specifier-instance (face-foreground face) frame))) 37
34 (defalias 'custom-face-foreground 'face-foreground)) 38 ;; Originally, this did much more stuff, and cached the results. The
35 39 ;; trouble is that, if user changes the bg color of a frame's default
36 (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version) 40 ;; face, the cache wouldn't get updated. This version should be fast
37 'face-font-name 41 ;; enough for use without caching, I think.
38 'face-font)) 42 (defun get-frame-background-mode (frame)
39 43 "Detect background mode for FRAME."
40 (eval-and-compile 44 (let* ((color-instance (face-background-instance 'default frame))
41 (cond ((fboundp 'frame-property) 45 (mode (condition-case nil
42 ;; XEmacs. 46 (if (< (apply '+ (color-instance-rgb-components
43 (defalias 'custom-frame-parameter 'frame-property)) 47 color-instance)) 65536)
44 ((fboundp 'frame-parameter) 48 'dark
45 ;; Emacs 19.35. 49 'light)
46 (defalias 'custom-frame-parameter 'frame-parameter)) 50 ;; We'll get an error on a TTY; TTY-s are generally dark.
47 (t 51 (error 'dark))))
48 ;; Old emacsen. 52 ;(set-frame-property 'background-mode mode)
49 (defun custom-frame-parameter (frame property &optional default) 53 mode))
50 "Return FRAME's value for property PROPERTY." 54
51 (or (cdr (assq property (frame-parameters frame))) 55 ;;;###autoload
52 default))))
53
54 (unless (fboundp 'face-doc-string)
55 ;; XEmacs function missing in Emacs.
56 (defun face-doc-string (face)
57 "Get the documentation string for FACE."
58 (get face 'face-documentation)))
59
60 (unless (fboundp 'set-face-doc-string)
61 ;; XEmacs function missing in Emacs.
62 (defun set-face-doc-string (face string)
63 "Set the documentation string for FACE to STRING."
64 (put face 'face-documentation string))))
65
66 (unless (fboundp 'x-color-values)
67 ;; Emacs function missing in XEmacs 19.14.
68 (defun x-color-values (color &optional frame)
69 "Return a description of the color named COLOR on frame FRAME.
70 The value is a list of integer RGB values--(RED GREEN BLUE).
71 These values appear to range from 0 to 65280 or 65535, depending
72 on the system; white is (65280 65280 65280) or (65535 65535 65535).
73 If FRAME is omitted or nil, use the selected frame."
74 (color-instance-rgb-components (make-color-instance color))))
75
76 ;; XEmacs and Emacs have different definitions of `facep'.
77 ;; The Emacs definition is the useful one, so emulate that.
78 (cond ((not (fboundp 'facep))
79 (defun custom-facep (face)
80 "No faces"
81 nil))
82 ((string-match "XEmacs" emacs-version)
83 (defalias 'custom-facep 'find-face))
84 (t
85 (defalias 'custom-facep 'facep)))
86
87 (unless (fboundp 'make-empty-face)
88 ;; This should be moved to `faces.el'.
89 (cond
90 ((string-match "XEmacs" emacs-version)
91 ;; Give up for old XEmacs pre 19.15/20.1.
92 (defalias 'make-empty-face 'make-face))
93 ((fboundp 'internal-find-face)
94 ;; We can do faces...
95 (defun make-empty-face (name)
96 "Define a new FACE on all frames, ignoring X resources."
97 (interactive "SMake face: ")
98 (or (internal-find-face name)
99 (let ((face (make-vector 8 nil)))
100 (aset face 0 'face)
101 (aset face 1 name)
102 (let* ((frames (frame-list))
103 (inhibit-quit t)
104 (id (internal-next-face-id)))
105 (make-face-internal id)
106 (aset face 2 id)
107 (while frames
108 (set-frame-face-alist (car frames)
109 (cons (cons name (copy-sequence face))
110 (frame-face-alist (car frames))))
111 (setq frames (cdr frames)))
112 (setq global-face-data (cons (cons name face) global-face-data)))
113 ;; add to menu
114 (if (fboundp 'facemenu-add-new-face)
115 (facemenu-add-new-face name))
116 face))
117 name))
118 (t
119 (fset 'make-empty-face 'ignore))))
120
121 (defcustom initialize-face-resources t 56 (defcustom initialize-face-resources t
122 "If non nil, allow X resources to initialize face properties. 57 "If non nil, allow X resources to initialize face properties.
123 This only affects faces declared with `defface', and only NT or X11 frames." 58 This only affects faces declared with `defface', and only X11 frames."
124 :group 'customize 59 :group 'faces
125 :type 'boolean) 60 :type 'boolean)
126 61
127 (cond ((fboundp 'initialize-face-resources) 62 (defun initialize-face-resources (face &optional frame)
128 ;; Already bound, do nothing. 63 "Initialize face according to the X11 resources.
129 )
130 ((fboundp 'make-face-x-resource-internal)
131 ;; Emacs or new XEmacs.
132 (defun initialize-face-resources (face &optional frame)
133 "Initialize face according to the X11 resources.
134 This might overwrite existing face properties. 64 This might overwrite existing face properties.
135 Does nothing when the variable initialize-face-resources is nil." 65 Does nothing when the variable initialize-face-resources is nil."
136 (when initialize-face-resources 66 (when initialize-face-resources
137 (make-face-x-resource-internal face frame t)))) 67 (make-face-x-resource-internal face frame t)))
138 (t
139 ;; Too hard to do right on XEmacs.
140 (defalias 'initialize-face-resources 'ignore)))
141 68
142 ;;(if (string-match "XEmacs" emacs-version) 69 ;;(if (string-match "XEmacs" emacs-version)
143 ;; ;; Xemacs. 70 ;; ;; Xemacs.
144 ;; (defun custom-invert-face (face &optional frame) 71 ;; (defun custom-invert-face (face &optional frame)
145 ;; "Swap the foreground and background colors of face FACE. 72 ;; "Swap the foreground and background colors of face FACE.
154 ;; "Swap the foreground and background colors of face FACE. 81 ;; "Swap the foreground and background colors of face FACE.
155 ;;If the colors are not specified in the face, use the default colors." 82 ;;If the colors are not specified in the face, use the default colors."
156 ;; (interactive (list (read-face-name "Reverse face: "))) 83 ;; (interactive (list (read-face-name "Reverse face: ")))
157 ;; (let ((fg (or (face-foreground face frame) 84 ;; (let ((fg (or (face-foreground face frame)
158 ;; (face-foreground 'default frame) 85 ;; (face-foreground 'default frame)
159 ;; (custom-frame-parameter (or frame (selected-frame)) 86 ;; (frame-property (or frame (selected-frame))
160 ;; 'foreground-color) 87 ;; 'foreground-color)
161 ;; "black")) 88 ;; "black"))
162 ;; (bg (or (face-background face frame) 89 ;; (bg (or (face-background face frame)
163 ;; (face-background 'default frame) 90 ;; (face-background 'default frame)
164 ;; (custom-frame-parameter (or frame (selected-frame)) 91 ;; (frame-property (or frame (selected-frame))
165 ;; 'background-color) 92 ;; 'background-color)
166 ;; "white"))) 93 ;; "white")))
167 ;; (set-face-foreground face bg frame) 94 ;; (set-face-foreground face bg frame)
168 ;; (set-face-background face fg frame)))) 95 ;; (set-face-background face fg frame))))
169 96
170 (defcustom custom-background-mode nil 97 (defun custom-extract-frame-properties (frame)
171 "The brightness of the background. 98 "Return a plist with the frame properties of FRAME used by custom."
172 Set this to the symbol dark if your background color is dark, light if 99 (list 'type (device-type (frame-device frame))
173 your background is light, or nil (default) if you want Emacs to 100 'class (device-class (frame-device frame))
174 examine the brightness for you." 101 'background (or frame-background-mode
175 :group 'customize 102 (frame-property frame 'background-mode)
176 :type '(choice (const dark) 103 (get-frame-background-mode frame))))
177 (const light)
178 (const :tag "default" nil)))
179
180 (defun custom-background-mode (frame)
181 "Kludge to detect background mode for FRAME."
182 (let* ((bg-resource
183 (condition-case ()
184 (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
185 (error nil)))
186 color
187 (mode (cond (bg-resource
188 (intern (downcase bg-resource)))
189 ((and (setq color (condition-case ()
190 (or (custom-frame-parameter
191 frame
192 'background-color)
193 (custom-face-background
194 'default))
195 (error nil)))
196 (or (string-match "XEmacs" emacs-version)
197 window-system)
198 (< (apply '+ (x-color-values color))
199 (/ (apply '+ (x-color-values "white"))
200 3)))
201 'dark)
202 (t 'light))))
203 (modify-frame-parameters frame (list (cons 'background-mode mode)))
204 mode))
205
206 (eval-and-compile
207 (if (string-match "XEmacs" emacs-version)
208 ;; XEmacs.
209 (defun custom-extract-frame-properties (frame)
210 "Return a plist with the frame properties of FRAME used by custom."
211 (list 'type (device-type (frame-device frame))
212 'class (device-class (frame-device frame))
213 'background (or custom-background-mode
214 (custom-frame-parameter frame
215 'background-mode)
216 (custom-background-mode frame))))
217 ;; Emacs.
218 (defun custom-extract-frame-properties (frame)
219 "Return a plist with the frame properties of FRAME used by custom."
220 (list 'type window-system
221 'class (custom-frame-parameter frame 'display-type)
222 'background (or custom-background-mode
223 (custom-frame-parameter frame 'background-mode)
224 (custom-background-mode frame))))))
225 104
226 ;;; Declaring a face. 105 ;;; Declaring a face.
227 106
228 ;;;###autoload 107 ;;;###autoload
229 (defun custom-declare-face (face spec doc &rest args) 108 (defun custom-declare-face (face spec doc &rest args)
230 "Like `defface', but FACE is evaluated as a normal argument." 109 "Like `defface', but FACE is evaluated as a normal argument."
231 (when (or (fboundp 'load-gc) ;XEmacs. 110 (when (fboundp 'load-gc)
232 ;; Emacs. 111 ;; This should be allowed, using specifiers.
233 (and (boundp purify-flag) purify-flag))
234 ;; This should be allowed, somehow.
235 (error "Attempt to declare a face during dump")) 112 (error "Attempt to declare a face during dump"))
236 (unless (get face 'face-defface-spec) 113 (unless (get face 'face-defface-spec)
237 (put face 'face-defface-spec spec) 114 (put face 'face-defface-spec spec)
238 (when (fboundp 'facep) 115 (unless (find-face face)
239 (unless (custom-facep face) 116 ;; If the user has already created the face, respect that.
240 ;; If the user has already created the face, respect that. 117 (let ((value (or (get face 'saved-face) spec))
241 (let ((value (or (get face 'saved-face) spec)) 118 (frames (custom-relevant-frames))
242 (frames (custom-relevant-frames)) 119 frame)
243 frame) 120 ;; Create global face.
244 ;; Create global face. 121 (make-empty-face face)
245 (make-empty-face face) 122 (custom-face-display-set face value)
246 (custom-face-display-set face value) 123 ;; Create frame local faces
247 ;; Create frame local faces 124 (while frames
248 (while frames 125 (setq frame (car frames)
249 (setq frame (car frames) 126 frames (cdr frames))
250 frames (cdr frames)) 127 (custom-face-display-set face value frame))
251 (custom-face-display-set face value frame)) 128 (initialize-face-resources face)))
252 (initialize-face-resources face))))
253 (when (and doc (null (face-doc-string face))) 129 (when (and doc (null (face-doc-string face)))
254 (set-face-doc-string face doc)) 130 (set-face-doc-string face doc))
255 (custom-handle-all-keywords face args 'custom-face) 131 (custom-handle-all-keywords face args 'custom-face)
256 (run-hooks 'custom-define-hook)) 132 (run-hooks 'custom-define-hook))
257 face) 133 face)
134
135 (defun custom-face-background (face &optional frame)
136 "Return the background color name of face FACE, or nil if unspecified."
137 (color-instance-name (specifier-instance (face-background face) frame)))
138
139 (defun custom-face-foreground (face &optional frame)
140 "Return the background color name of face FACE, or nil if unspecified."
141 (color-instance-name (specifier-instance (face-foreground face) frame)))
258 142
259 ;;; Font Attributes. 143 ;;; Font Attributes.
260 144
261 (defconst custom-face-attributes 145 (defconst custom-face-attributes
262 '((:bold (boolean :tag "Bold" 146 '((:bold (boolean :tag "Bold"
336 (setq att (car atts) 220 (setq att (car atts)
337 atts (cdr atts) 221 atts (cdr atts)
338 get (nth 3 att)) 222 get (nth 3 att))
339 (condition-case nil 223 (condition-case nil
340 ;; This may fail if w3 doesn't exists. 224 ;; This may fail if w3 doesn't exists.
341 (when get 225 (when get
342 (let ((answer (funcall get face frame))) 226 (let ((answer (funcall get face frame)))
343 (unless (equal answer (funcall get 'default frame)) 227 (unless (equal answer (funcall get 'default frame))
344 (when (widget-apply (nth 1 att) :match answer) 228 (when (widget-apply (nth 1 att) :match answer)
345 (setq result (cons (nth 0 att) (cons answer result))))))) 229 (setq result (cons (nth 0 att) (cons answer result)))))))
346 (error nil))) 230 (error nil)))
352 (make-face-bold face frame) 236 (make-face-bold face frame)
353 (make-face-unbold face frame))) 237 (make-face-unbold face frame)))
354 238
355 (defun custom-face-bold (face &rest args) 239 (defun custom-face-bold (face &rest args)
356 "Return non-nil if the font of FACE is bold." 240 "Return non-nil if the font of FACE is bold."
357 (let* ((font (apply 'custom-face-font-name face args)) 241 (let* ((font (apply 'face-font-name face args))
358 (fontobj (font-create-object font))) 242 (fontobj (font-create-object font)))
359 (font-bold-p fontobj))) 243 (font-bold-p fontobj)))
360 244
361 (defun custom-set-face-italic (face value &optional frame) 245 (defun custom-set-face-italic (face value &optional frame)
362 "Set the italic property of FACE to VALUE." 246 "Set the italic property of FACE to VALUE."
364 (make-face-italic face frame) 248 (make-face-italic face frame)
365 (make-face-unitalic face frame))) 249 (make-face-unitalic face frame)))
366 250
367 (defun custom-face-italic (face &rest args) 251 (defun custom-face-italic (face &rest args)
368 "Return non-nil if the font of FACE is italic." 252 "Return non-nil if the font of FACE is italic."
369 (let* ((font (apply 'custom-face-font-name face args)) 253 (let* ((font (apply 'face-font-name face args))
370 (fontobj (font-create-object font))) 254 (fontobj (font-create-object font)))
371 (font-italic-p fontobj))) 255 (font-italic-p fontobj)))
372 256
373 (defun custom-face-stipple (face &rest args) 257 (defun custom-face-stipple (face &rest args)
374 "Return the name of the stipple file used for FACE." 258 "Return the name of the stipple file used for FACE."
375 (if (string-match "XEmacs" emacs-version) 259 (let ((image (apply 'specifier-instance
376 (let ((image (apply 'specifier-instance 260 (face-background-pixmap face) args)))
377 (face-background-pixmap face) args))) 261 (and image
378 (when image 262 (image-instance-file-name image))))
379 (image-instance-file-name image))) 263
380 (apply 'face-stipple face args))) 264 (defun custom-set-face-font-size (face size &rest args)
381 265 "Set the font of FACE to SIZE"
382 (when (string-match "XEmacs" emacs-version) 266 (let* ((font (apply 'face-font-name face args))
383 ;; Support for special XEmacs font attributes. 267 (fontobj (font-create-object font)))
384 (autoload 'font-create-object "font" nil) 268 (set-font-size fontobj size)
385 269 (apply 'font-set-face-font face fontobj args)))
386 (defun custom-set-face-font-size (face size &rest args) 270
387 "Set the font of FACE to SIZE" 271 (defun custom-face-font-size (face &rest args)
388 (let* ((font (apply 'custom-face-font-name face args)) 272 "Return the size of the font of FACE as a string."
389 (fontobj (font-create-object font))) 273 (let* ((font (apply 'face-font-name face args))
390 (set-font-size fontobj size) 274 (fontobj (font-create-object font)))
391 (apply 'font-set-face-font face fontobj args))) 275 (format "%s" (font-size fontobj))))
392 276
393 (defun custom-face-font-size (face &rest args) 277 (defun custom-set-face-font-family (face family &rest args)
394 "Return the size of the font of FACE as a string." 278 "Set the font of FACE to FAMILY."
395 (let* ((font (apply 'custom-face-font-name face args)) 279 (let* ((font (apply 'face-font-name face args))
396 (fontobj (font-create-object font))) 280 (fontobj (font-create-object font)))
397 (format "%s" (font-size fontobj)))) 281 (set-font-family fontobj family)
398 282 (apply 'font-set-face-font face fontobj args)))
399 (defun custom-set-face-font-family (face family &rest args) 283
400 "Set the font of FACE to FAMILY." 284 (defun custom-face-font-family (face &rest args)
401 (let* ((font (apply 'custom-face-font-name face args)) 285 "Return the name of the font family of FACE."
402 (fontobj (font-create-object font))) 286 (let* ((font (apply 'face-font-name face args))
403 (set-font-family fontobj family) 287 (fontobj (font-create-object font)))
404 (apply 'font-set-face-font face fontobj args))) 288 (font-family fontobj)))
405 289
406 (defun custom-face-font-family (face &rest args) 290 (setq custom-face-attributes
407 "Return the name of the font family of FACE." 291 (append '((:family (editable-field :format "Font Family: %v"
408 (let* ((font (apply 'custom-face-font-name face args)) 292 :help-echo "\
409 (fontobj (font-create-object font)))
410 (font-family fontobj)))
411
412 (setq custom-face-attributes
413 (append '((:family (editable-field :format "Font Family: %v"
414 :help-echo "\
415 Name of font family to use (e.g. times).") 293 Name of font family to use (e.g. times).")
416 custom-set-face-font-family 294 custom-set-face-font-family
417 custom-face-font-family) 295 custom-face-font-family)
418 (:size (editable-field :format "Size: %v" 296 (:size (editable-field :format "Size: %v"
419 :help-echo "\ 297 :help-echo "\
420 Text size (e.g. 9pt or 2mm).") 298 Text size (e.g. 9pt or 2mm).")
421 custom-set-face-font-size 299 custom-set-face-font-size
422 custom-face-font-size) 300 custom-face-font-size)
423 (:strikethru (toggle :format "%[Strikethru%]: %v\n" 301 (:strikethru (toggle :format "%[Strikethru%]: %v\n"
424 :help-echo "\ 302 :help-echo "\
425 Control whether the text should be strikethru.") 303 Control whether the text should be strikethru.")
426 set-face-strikethru-p 304 set-face-strikethru-p
427 face-strikethru-p)) 305 face-strikethru-p))
428 custom-face-attributes))) 306 custom-face-attributes))
429
430 ;;; Frames. 307 ;;; Frames.
431 308
432 (defun face-spec-set (face spec &optional frame) 309 (defun face-spec-set (face spec &optional frame)
433 "Set FACE to the attributes to the first matching entry in SPEC. 310 "Set FACE to the attributes to the first matching entry in SPEC.
434 Iff optional FRAME is non-nil, set it for that frame only. 311 Iff optional FRAME is non-nil, set it for that frame only.
435 See `defface' for information about SPEC. 312 See `defface' for information about SPEC.
436 313
437 Clear all existing attributes first." 314 Clear all existing attributes first."
438 (when (fboundp 'copy-face) 315 (copy-face 'custom-face-empty face frame)
439 (copy-face 'custom-face-empty face frame))
440 (custom-face-display-set face spec frame)) 316 (custom-face-display-set face spec frame))
441 317
442 (defun custom-face-display-set (face spec &optional frame) 318 (defun custom-face-display-set (face spec &optional frame)
443 "Set FACE to the attributes to the first matching entry in SPEC. 319 "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. 320 Iff optional FRAME is non-nil, set it for that frame only.
445 See `defface' for information about SPEC." 321 See `defface' for information about SPEC."
446 (when (fboundp 'make-face) 322 (while spec
447 (while spec 323 (let* ((entry (car spec))
448 (let* ((entry (car spec)) 324 (display (nth 0 entry))
449 (display (nth 0 entry)) 325 (atts (nth 1 entry)))
450 (atts (nth 1 entry))) 326 (setq spec (cdr spec))
451 (setq spec (cdr spec)) 327 (when (face-spec-set-match-display display frame)
452 (when (face-spec-set-match-display display frame) 328 ;; Avoid creating frame local duplicates of the global face.
453 ;; Avoid creating frame local duplicates of the global face. 329 (unless (and frame (eq display (get face 'custom-face-display)))
454 (unless (and frame (eq display (get face 'custom-face-display))) 330 (apply 'custom-face-attributes-set face frame atts))
455 (apply 'custom-face-attributes-set face frame atts)) 331 (unless frame
456 (unless frame 332 (put face 'custom-face-display display))
457 (put face 'custom-face-display display)) 333 (setq spec nil)))))
458 (setq spec nil))))))
459 334
460 (defvar custom-default-frame-properties nil 335 (defvar custom-default-frame-properties nil
461 "The frame properties used for the global faces. 336 "The frame properties used for the global faces.
462 Frames who doesn't match these propertiess should have frame local faces. 337 Frames who doesn't match these propertiess should have frame local faces.
463 The value should be nil, if uninitialized, or a plist otherwise. 338 The value should be nil, if uninitialized, or a plist otherwise.
466 (defun custom-get-frame-properties (&optional frame) 341 (defun custom-get-frame-properties (&optional frame)
467 "Return a plist with the frame properties of FRAME used by custom. 342 "Return a plist with the frame properties of FRAME used by custom.
468 If FRAME is nil, return the default frame properties." 343 If FRAME is nil, return the default frame properties."
469 (cond (frame 344 (cond (frame
470 ;; Try to get from cache. 345 ;; Try to get from cache.
471 (let ((cache (custom-frame-parameter frame 'custom-properties))) 346 (let ((cache (frame-property frame 'custom-properties)))
472 (unless cache 347 (unless cache
473 ;; Oh well, get it then. 348 ;; Oh well, get it then.
474 (setq cache (custom-extract-frame-properties frame)) 349 (setq cache (custom-extract-frame-properties frame))
475 ;; and cache it... 350 ;; and cache it...
476 (modify-frame-parameters frame 351 (modify-frame-parameters frame
504 ((eq req 'class) 379 ((eq req 'class)
505 (memq class options)) 380 (memq class options))
506 ((eq req 'background) 381 ((eq req 'background)
507 (memq background options)) 382 (memq background options))
508 (t 383 (t
509 (message (format "\ 384 (warn "Unknown req `%S' with options `%S'"
510 Warning: Unknown req `%S' with options `%S'" req options)) 385 req options)
511 nil)))) 386 nil))))
512 match))) 387 match)))
513 388
514 (defun custom-relevant-frames () 389 (defun custom-relevant-frames ()
515 "List of frames whose custom properties differ from the default." 390 "List of frames whose custom properties differ from the default."
525 relevant)) 400 relevant))
526 401
527 (defun custom-initialize-faces (&optional frame) 402 (defun custom-initialize-faces (&optional frame)
528 "Initialize all custom faces for FRAME. 403 "Initialize all custom faces for FRAME.
529 If FRAME is nil or omitted, initialize them for all frames." 404 If FRAME is nil or omitted, initialize them for all frames."
530 (mapcar (lambda (symbol) 405 (mapc (lambda (symbol)
531 (let ((spec (or (get symbol 'saved-face) 406 (let ((spec (or (get symbol 'saved-face)
532 (get symbol 'face-defface-spec)))) 407 (get symbol 'face-defface-spec))))
533 (when spec 408 (when spec
534 (custom-face-display-set symbol spec frame) 409 (custom-face-display-set symbol spec frame)
535 (initialize-face-resources symbol frame)))) 410 (initialize-face-resources symbol frame))))
536 (face-list))) 411 (face-list)))
537 412
538 ;;;###autoload 413 ;;;###autoload
539 (defun custom-initialize-frame (&optional frame) 414 (defun custom-initialize-frame (&optional frame)
540 "Initialize local faces for FRAME if necessary. 415 "Initialize local faces for FRAME if necessary.
541 If FRAME is missing or nil, the first member of (frame-list) is used." 416 If FRAME is missing or nil, the first member of (frame-list) is used."
545 (custom-get-frame-properties frame)) 420 (custom-get-frame-properties frame))
546 (custom-initialize-faces frame))) 421 (custom-initialize-faces frame)))
547 422
548 ;;; Initializing. 423 ;;; Initializing.
549 424
550 (and (fboundp 'make-face) 425 (make-face 'custom-face-empty)
551 (make-face 'custom-face-empty))
552 426
553 ;;;###autoload 427 ;;;###autoload
554 (defun custom-set-faces (&rest args) 428 (defun custom-set-faces (&rest args)
555 "Initialize faces according to user preferences. 429 "Initialize faces according to user preferences.
556 The arguments should be a list where each entry has the form: 430 The arguments should be a list where each entry has the form:
568 (spec (nth 1 entry)) 442 (spec (nth 1 entry))
569 (now (nth 2 entry))) 443 (now (nth 2 entry)))
570 (put face 'saved-face spec) 444 (put face 'saved-face spec)
571 (when now 445 (when now
572 (put face 'force-face t)) 446 (put face 'force-face t))
573 (when (or now (custom-facep face)) 447 (when (or now (find-face face))
574 (face-spec-set face spec)) 448 (face-spec-set face spec))
575 (setq args (cdr args))) 449 (setq args (cdr args)))
576 ;; Old format, a plist of FACE SPEC pairs. 450 ;; Old format, a plist of FACE SPEC pairs.
577 (let ((face (nth 0 args)) 451 (let ((face (nth 0 args))
578 (spec (nth 1 args))) 452 (spec (nth 1 args)))