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