Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 197:acd284d43ca1 r20-3b25

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b25
author cvs
date Mon, 13 Aug 2007 10:00:02 +0200
parents a2f645c6b9f8
children 169c0442b401
comparison
equal deleted inserted replaced
196:58e0786448ca 197:acd284d43ca1
21 21
22 ;; To elude the warnings for font functions. 22 ;; To elude the warnings for font functions.
23 (eval-when-compile 23 (eval-when-compile
24 (require 'font)) 24 (require 'font))
25 25
26 ;;;###autoload
27 (defcustom frame-background-mode nil
28 "*The brightness of the background.
29 Set this to the symbol dark if your background color is dark, light if
30 your background is light, or nil (default) if you want Emacs to
31 examine the brightness for you."
32 :group 'faces
33 :type '(choice (choice-item dark)
34 (choice-item light)
35 (choice-item :tag "Auto" nil)))
36
37
38 ;; Originally, this did much more stuff, and cached the results. The
39 ;; trouble is that, if user changes the bg color of a frame's default
40 ;; face, the cache wouldn't get updated. This version should be fast
41 ;; enough for use without caching, I think.
42 (defun get-frame-background-mode (frame)
43 "Detect background mode for FRAME."
44 (let* ((color-instance (face-background-instance 'default frame))
45 (mode (condition-case nil
46 (if (< (apply '+ (color-instance-rgb-components
47 color-instance)) 65536)
48 'dark
49 'light)
50 ;; We'll get an error on a TTY; TTY-s are generally dark.
51 (error 'dark))))
52 ;(set-frame-property 'background-mode mode)
53 mode))
54
55 ;;;###autoload
56 (defcustom initialize-face-resources t
57 "If non nil, allow X resources to initialize face properties.
58 This only affects faces declared with `defface', and only X11 frames."
59 :group 'faces
60 :type 'boolean)
61
62 (defun initialize-face-resources (face &optional frame)
63 "Initialize face according to the X11 resources.
64 This might overwrite existing face properties.
65 Does nothing when the variable initialize-face-resources is nil."
66 (when initialize-face-resources
67 (make-face-x-resource-internal face frame t)))
68
69 ;;(if (string-match "XEmacs" emacs-version)
70 ;; ;; Xemacs.
71 ;; (defun custom-invert-face (face &optional frame)
72 ;; "Swap the foreground and background colors of face FACE.
73 ;;If the colors are not specified in the face, use the default colors."
74 ;; (interactive (list (read-face-name "Reverse face: ")))
75 ;; (let ((fg (color-name (face-foreground face frame) frame))
76 ;; (bg (color-name (face-background face frame) frame)))
77 ;; (set-face-foreground face bg frame)
78 ;; (set-face-background face fg frame)))
79 ;; ;; Emacs.
80 ;; (defun custom-invert-face (face &optional frame)
81 ;; "Swap the foreground and background colors of face FACE.
82 ;;If the colors are not specified in the face, use the default colors."
83 ;; (interactive (list (read-face-name "Reverse face: ")))
84 ;; (let ((fg (or (face-foreground face frame)
85 ;; (face-foreground 'default frame)
86 ;; (frame-property (or frame (selected-frame))
87 ;; 'foreground-color)
88 ;; "black"))
89 ;; (bg (or (face-background face frame)
90 ;; (face-background 'default frame)
91 ;; (frame-property (or frame (selected-frame))
92 ;; 'background-color)
93 ;; "white")))
94 ;; (set-face-foreground face bg frame)
95 ;; (set-face-background face fg frame))))
96
97 (defun custom-extract-frame-properties (frame)
98 "Return a plist with the frame properties of FRAME used by custom."
99 (list 'type (device-type (frame-device frame))
100 'class (device-class (frame-device frame))
101 'background (or frame-background-mode
102 (frame-property frame 'background-mode)
103 (get-frame-background-mode frame))))
104
105 ;;; Declaring a face. 26 ;;; Declaring a face.
106 27
107 ;;;###autoload 28 ;;;###autoload
108 (defun custom-declare-face (face spec doc &rest args) 29 (defun custom-declare-face (face spec doc &rest args)
109 "Like `defface', but FACE is evaluated as a normal argument." 30 "Like `defface', but FACE is evaluated as a normal argument."
110 (when (fboundp 'load-gc) 31 ;; (when (fboundp 'load-gc)
111 ;; This should be allowed, using specifiers. 32 ;; (error "Attempt to declare a face during dump"))
112 (error "Attempt to declare a face during dump"))
113 (unless (get face 'face-defface-spec) 33 (unless (get face 'face-defface-spec)
114 (put face 'face-defface-spec spec) 34 (put face 'face-defface-spec spec)
115 (unless (find-face face) 35 (unless (find-face face)
116 ;; If the user has already created the face, respect that. 36 ;; If the user has already created the face, respect that.
117 (let ((value (or (get face 'saved-face) spec)) 37 (let ((value (or (get face 'saved-face) spec))
118 (frames (custom-relevant-frames)) 38 (frames (relevant-custom-frames))
119 frame) 39 frame)
120 ;; Create global face. 40 ;; Create global face.
121 (make-empty-face face) 41 (make-empty-face face)
122 (custom-face-display-set face value) 42 (face-display-set face value)
123 ;; Create frame local faces 43 ;; Create frame local faces
124 (while frames 44 (while frames
125 (setq frame (car frames) 45 (setq frame (car frames)
126 frames (cdr frames)) 46 frames (cdr frames))
127 (custom-face-display-set face value frame)) 47 (face-display-set face value frame))
128 (initialize-face-resources face))) 48 (init-face-from-resources face)))
129 (when (and doc (null (face-doc-string face))) 49 (when (and doc (null (face-doc-string face)))
130 (set-face-doc-string face doc)) 50 (set-face-doc-string face doc))
131 (custom-handle-all-keywords face args 'custom-face) 51 (custom-handle-all-keywords face args 'custom-face)
132 (run-hooks 'custom-define-hook)) 52 (run-hooks 'custom-define-hook))
133 face) 53 face)
134 54
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)))
142
143 ;;; Font Attributes. 55 ;;; Font Attributes.
144 56
145 (defconst custom-face-attributes 57 (defconst custom-face-attributes
146 '((:bold (boolean :tag "Bold" 58 '((:bold (boolean :tag "Bold"
147 :help-echo "Control whether a bold font should be used.") 59 :help-echo "Control whether a bold font should be used.")
148 custom-set-face-bold 60 custom-set-face-bold custom-face-bold)
149 custom-face-bold)
150 (:italic (boolean :tag "Italic" 61 (:italic (boolean :tag "Italic"
151 :help-echo "\ 62 :help-echo "\
152 Control whether an italic font should be used.") 63 Control whether an italic font should be used.")
153 custom-set-face-italic 64 custom-set-face-italic custom-face-italic)
154 custom-face-italic)
155 (:underline (boolean :tag "Underline" 65 (:underline (boolean :tag "Underline"
156 :help-echo "\ 66 :help-echo "\
157 Control whether the text should be underlined.") 67 Control whether the text should be underlined.")
158 set-face-underline-p 68 set-face-underline-p face-underline-p)
159 face-underline-p)
160 (:foreground (color :tag "Foreground" 69 (:foreground (color :tag "Foreground"
161 :value "" 70 :value ""
162 :help-echo "Set foreground color.") 71 :help-echo "Set foreground color.")
163 set-face-foreground 72 set-face-foreground custom-face-foreground)
164 custom-face-foreground)
165 (:background (color :tag "Background" 73 (:background (color :tag "Background"
166 :value "" 74 :value ""
167 :help-echo "Set background color.") 75 :help-echo "Set background color.")
168 set-face-background 76 set-face-background custom-face-background)
169 custom-face-background) 77 ;; (:reverse-video (boolean :tag "Reverse"
170 ;; (:invert (const :format "Invert Face\n" 78 ;; :help-echo "\
171 ;; :sibling-args (:help-echo " 79 ;;Control whether the text should be inverted.")
172 ;;Reverse the foreground and background color. 80 ;; custom-reverse-face custom-face-reverse)
173 ;;If you haven't specified them for the face, the default colors will be used.")
174 ;; t)
175 ;; (lambda (face value &optional frame)
176 ;; ;; We don't use VALUE.
177 ;; (custom-invert-face face frame)))
178 (:stipple (editable-field :format "Stipple: %v" 81 (:stipple (editable-field :format "Stipple: %v"
179 :help-echo "Name of background bitmap file.") 82 :help-echo "Name of background bitmap file.")
180 set-face-stipple custom-face-stipple)) 83 set-face-background-pixmap custom-face-stipple)
84 (:family (editable-field :format "Font Family: %v"
85 :help-echo "\
86 Name of font family to use (e.g. times).")
87 custom-set-face-font-family custom-face-font-family)
88 (:size (editable-field :format "Size: %v"
89 :help-echo "\
90 Text size (e.g. 9pt or 2mm).")
91 custom-set-face-font-size custom-face-font-size)
92 (:strikethru (toggle :format "%[Strikethru%]: %v\n"
93 :help-echo "\
94 Control whether the text should be strikethru.")
95 set-face-strikethru-p face-strikethru-p))
181 "Alist of face attributes. 96 "Alist of face attributes.
182 97
183 The elements are of the form (KEY TYPE SET GET) where KEY is a symbol 98 The elements are of the form (KEY TYPE SET GET) where KEY is a symbol
184 identifying the attribute, TYPE is a widget type for editing the 99 identifying the attribute, TYPE is a widget type for editing the
185 attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. 100 attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value.
189 be changed. 104 be changed.
190 105
191 The GET function should take two arguments, the face to examine, and 106 The GET function should take two arguments, the face to examine, and
192 optonally the frame where the face should be examined.") 107 optonally the frame where the face should be examined.")
193 108
194 (defun custom-face-attributes-set (face frame &rest atts) 109 (defun face-custom-attributes-set (face frame &rest atts)
195 "For FACE on FRAME set the attributes [KEYWORD VALUE].... 110 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
196 Each keyword should be listed in `custom-face-attributes'. 111 Each keyword should be listed in `custom-face-attributes'.
197 112
198 If FRAME is nil, set the default face." 113 If FRAME is nil, set the default face."
199 (while atts 114 (while atts
200 (let* ((name (nth 0 atts)) 115 (let* ((name (nth 0 atts))
201 (value (nth 1 atts)) 116 (value (nth 1 atts))
202 (fun (nth 2 (assq name custom-face-attributes)))) 117 (fun (nth 2 (assq name custom-face-attributes))))
203 (setq atts (cdr (cdr atts))) 118 (setq atts (cdr (cdr atts)))
204 (condition-case nil 119 (condition-case nil
205 (funcall fun face value frame) 120 (funcall fun face value frame)
206 (error nil))))) 121 (error nil)))))
207 122
208 (defun custom-face-attributes-get (face frame) 123 (defun face-custom-attributes-get (face frame)
209 "For FACE on FRAME get the attributes [KEYWORD VALUE].... 124 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
210 Each keyword should be listed in `custom-face-attributes'. 125 Each keyword should be listed in `custom-face-attributes'.
211 126
212 If FRAME is nil, use the default face." 127 If FRAME is nil, use the default face."
213 (condition-case nil 128 (condition-case nil
234 "Set the bold property of FACE to VALUE." 149 "Set the bold property of FACE to VALUE."
235 (if value 150 (if value
236 (make-face-bold face frame) 151 (make-face-bold face frame)
237 (make-face-unbold face frame))) 152 (make-face-unbold face frame)))
238 153
154 ;; Really, we should get rid of these font.el dependencies... They
155 ;; are still presenting a problem with dumping the faces (font.el is
156 ;; too bloated for us to dump). I am thinking about hacking up
157 ;; font-like functionality myself for the sake of this file. It will
158 ;; probably be to-the-point and more efficient.
159
239 (defun custom-face-bold (face &rest args) 160 (defun custom-face-bold (face &rest args)
240 "Return non-nil if the font of FACE is bold." 161 "Return non-nil if the font of FACE is bold."
241 (let* ((font (apply 'face-font-name face args)) 162 (let* ((font (apply 'face-font-name face args))
163 ;; Gag
242 (fontobj (font-create-object font))) 164 (fontobj (font-create-object font)))
243 (font-bold-p fontobj))) 165 (font-bold-p fontobj)))
244 166
245 (defun custom-set-face-italic (face value &optional frame) 167 (defun custom-set-face-italic (face value &optional frame)
246 "Set the italic property of FACE to VALUE." 168 "Set the italic property of FACE to VALUE."
249 (make-face-unitalic face frame))) 171 (make-face-unitalic face frame)))
250 172
251 (defun custom-face-italic (face &rest args) 173 (defun custom-face-italic (face &rest args)
252 "Return non-nil if the font of FACE is italic." 174 "Return non-nil if the font of FACE is italic."
253 (let* ((font (apply 'face-font-name face args)) 175 (let* ((font (apply 'face-font-name face args))
176 ;; Gag
254 (fontobj (font-create-object font))) 177 (fontobj (font-create-object font)))
255 (font-italic-p fontobj))) 178 (font-italic-p fontobj)))
256 179
257 (defun custom-face-stipple (face &rest args) 180 (defun custom-face-stipple (face &rest args)
258 "Return the name of the stipple file used for FACE." 181 "Return the name of the stipple file used for FACE."
262 (image-instance-file-name image)))) 185 (image-instance-file-name image))))
263 186
264 (defun custom-set-face-font-size (face size &rest args) 187 (defun custom-set-face-font-size (face size &rest args)
265 "Set the font of FACE to SIZE" 188 "Set the font of FACE to SIZE"
266 (let* ((font (apply 'face-font-name face args)) 189 (let* ((font (apply 'face-font-name face args))
190 ;; Gag
267 (fontobj (font-create-object font))) 191 (fontobj (font-create-object font)))
268 (set-font-size fontobj size) 192 (set-font-size fontobj size)
269 (apply 'font-set-face-font face fontobj args))) 193 (apply 'font-set-face-font face fontobj args)))
270 194
271 (defun custom-face-font-size (face &rest args) 195 (defun custom-face-font-size (face &rest args)
272 "Return the size of the font of FACE as a string." 196 "Return the size of the font of FACE as a string."
273 (let* ((font (apply 'face-font-name face args)) 197 (let* ((font (apply 'face-font-name face args))
198 ;; Gag
274 (fontobj (font-create-object font))) 199 (fontobj (font-create-object font)))
275 (format "%s" (font-size fontobj)))) 200 (format "%s" (font-size fontobj))))
276 201
277 (defun custom-set-face-font-family (face family &rest args) 202 (defun custom-set-face-font-family (face family &rest args)
278 "Set the font of FACE to FAMILY." 203 "Set the font of FACE to FAMILY."
279 (let* ((font (apply 'face-font-name face args)) 204 (let* ((font (apply 'face-font-name face args))
205 ;; Gag
280 (fontobj (font-create-object font))) 206 (fontobj (font-create-object font)))
281 (set-font-family fontobj family) 207 (set-font-family fontobj family)
282 (apply 'font-set-face-font face fontobj args))) 208 (apply 'font-set-face-font face fontobj args)))
283 209
284 (defun custom-face-font-family (face &rest args) 210 (defun custom-face-font-family (face &rest args)
285 "Return the name of the font family of FACE." 211 "Return the name of the font family of FACE."
286 (let* ((font (apply 'face-font-name face args)) 212 (let* ((font (apply 'face-font-name face args))
213 ;; Gag
287 (fontobj (font-create-object font))) 214 (fontobj (font-create-object font)))
288 (font-family fontobj))) 215 (font-family fontobj)))
289 216
290 (setq custom-face-attributes 217 ;;(defun custom-reverse-face (face value &optional frame)
291 (append '((:family (editable-field :format "Font Family: %v" 218 ;; "Swap the foreground and background colors of face FACE.
292 :help-echo "\ 219 ;;If the colors are not specified in the face, use the default colors."
293 Name of font family to use (e.g. times).") 220 ;; (interactive (list (read-face-name "Reverse face: ")))
294 custom-set-face-font-family 221 ;; (when value
295 custom-face-font-family) 222 ;; (if (eq (frame-type) 'tty)
296 (:size (editable-field :format "Size: %v" 223 ;; (set-face-reverse-p face value frame)
297 :help-echo "\ 224 ;; (let ((fg (face-foreground-instance face frame))
298 Text size (e.g. 9pt or 2mm).") 225 ;; (bg (face-background-instance face frame)))
299 custom-set-face-font-size 226 ;; (set-face-foreground face bg frame)
300 custom-face-font-size) 227 ;; (set-face-background face fg frame)))))
301 (:strikethru (toggle :format "%[Strikethru%]: %v\n" 228
302 :help-echo "\ 229 ;;(defun custom-face-reverse (face &optional frame)
303 Control whether the text should be strikethru.") 230 ;; "Returns non-nil if the face is reverse."
304 set-face-strikethru-p 231 ;; (if (eq (frame-type) 'tty)
305 face-strikethru-p)) 232 ;; (face-reverse-p face frame)
306 custom-face-attributes)) 233 ;; ;;; ### Implement me
307 ;;; Frames. 234 ;; ))
308
309 (defun face-spec-set (face spec &optional frame)
310 "Set FACE to the attributes to the first matching entry in SPEC.
311 Iff optional FRAME is non-nil, set it for that frame only.
312 See `defface' for information about SPEC.
313
314 Clear all existing attributes first."
315 (copy-face 'custom-face-empty face frame)
316 (custom-face-display-set face spec frame))
317
318 (defun custom-face-display-set (face spec &optional frame)
319 "Set FACE to the attributes to the first matching entry in SPEC.
320 Iff optional FRAME is non-nil, set it for that frame only.
321 See `defface' for information about SPEC."
322 (while spec
323 (let* ((entry (car spec))
324 (display (nth 0 entry))
325 (atts (nth 1 entry)))
326 (setq spec (cdr spec))
327 (when (face-spec-set-match-display display frame)
328 ;; Avoid creating frame local duplicates of the global face.
329 (unless (and frame (eq display (get face 'custom-face-display)))
330 (apply 'custom-face-attributes-set face frame atts))
331 (unless frame
332 (put face 'custom-face-display display))
333 (setq spec nil)))))
334
335 (defvar custom-default-frame-properties nil
336 "The frame properties used for the global faces.
337 Frames who doesn't match these propertiess should have frame local faces.
338 The value should be nil, if uninitialized, or a plist otherwise.
339 See `defface' for a list of valid keys and values for the plist.")
340
341 (defun custom-get-frame-properties (&optional frame)
342 "Return a plist with the frame properties of FRAME used by custom.
343 If FRAME is nil, return the default frame properties."
344 (cond (frame
345 ;; Try to get from cache.
346 (let ((cache (frame-property frame 'custom-properties)))
347 (unless cache
348 ;; Oh well, get it then.
349 (setq cache (custom-extract-frame-properties frame))
350 ;; and cache it...
351 (modify-frame-parameters frame
352 (list (cons 'custom-properties cache))))
353 cache))
354 (custom-default-frame-properties)
355 (t
356 (setq custom-default-frame-properties
357 (custom-extract-frame-properties (selected-frame))))))
358
359 (defun face-spec-set-match-display (display frame)
360 "Non-nil iff DISPLAY matches FRAME.
361 If FRAME is nil, the current FRAME is used."
362 ;; This is a kludge to get started, we really should use specifiers!
363 (if (eq display t)
364 t
365 (let* ((props (custom-get-frame-properties frame))
366 (type (plist-get props 'type))
367 (class (plist-get props 'class))
368 (background (plist-get props 'background))
369 (match t)
370 (entries display)
371 entry req options)
372 (while (and entries match)
373 (setq entry (car entries)
374 entries (cdr entries)
375 req (car entry)
376 options (cdr entry)
377 match (cond ((eq req 'type)
378 (memq type options))
379 ((eq req 'class)
380 (memq class options))
381 ((eq req 'background)
382 (memq background options))
383 (t
384 (warn "Unknown req `%S' with options `%S'"
385 req options)
386 nil))))
387 match)))
388
389 (defun custom-relevant-frames ()
390 "List of frames whose custom properties differ from the default."
391 (let ((relevant nil)
392 (default (custom-get-frame-properties))
393 (frames (frame-list))
394 frame)
395 (while frames
396 (setq frame (car frames)
397 frames (cdr frames))
398 (unless (equal default (custom-get-frame-properties frame))
399 (push frame relevant)))
400 relevant))
401
402 (defun custom-initialize-faces (&optional frame)
403 "Initialize all custom faces for FRAME.
404 If FRAME is nil or omitted, initialize them for all frames."
405 (mapc (lambda (symbol)
406 (let ((spec (or (get symbol 'saved-face)
407 (get symbol 'face-defface-spec))))
408 (when spec
409 (custom-face-display-set symbol spec frame)
410 (initialize-face-resources symbol frame))))
411 (face-list)))
412
413 ;;;###autoload
414 (defun custom-initialize-frame (&optional frame)
415 "Initialize local faces for FRAME if necessary.
416 If FRAME is missing or nil, the first member of (frame-list) is used."
417 (unless frame
418 (setq frame (car (frame-list))))
419 (unless (equal (custom-get-frame-properties)
420 (custom-get-frame-properties frame))
421 (custom-initialize-faces frame)))
422 235
423 ;;; Initializing. 236 ;;; Initializing.
424
425 (make-face 'custom-face-empty)
426 237
427 ;;;###autoload 238 ;;;###autoload
428 (defun custom-set-faces (&rest args) 239 (defun custom-set-faces (&rest args)
429 "Initialize faces according to user preferences. 240 "Initialize faces according to user preferences.
430 The arguments should be a list where each entry has the form: 241 The arguments should be a list where each entry has the form: