Mercurial > hg > xemacs-beta

comparison lisp/cus-face.el @ 412:697ef44129c6 r21-2-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-14
author cvs
date Mon, 13 Aug 2007 11:20:41 +0200
parents 74fd4e045ea6
children ebe98a74bd68
comparison
equal deleted inserted replaced
411:12e008d41344 412:697ef44129c6
1 ;;; cus-face.el -- Support for Custom faces. 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@xemacs.org> 6 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
7 ;; Keywords: help, faces 7 ;; Keywords: help, faces
8 ;; Version: 1.9960-x 8 ;; Version: 1.9960-x
9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
10 10
11 ;;; Commentary: 11 ;;; Commentary:
28 ;;;###autoload 28 ;;;###autoload
29 (defun custom-declare-face (face spec doc &rest args) 29 (defun custom-declare-face (face spec doc &rest args)
30 "Like `defface', but FACE is evaluated as a normal argument." 30 "Like `defface', but FACE is evaluated as a normal argument."
31 ;; (when (fboundp 'pureload) 31 ;; (when (fboundp 'pureload)
32 ;; (error "Attempt to declare a face during dump")) 32 ;; (error "Attempt to declare a face during dump"))
33 ;; #### should we possibly reset force-face here?
34 (unless (get face 'face-defface-spec) 33 (unless (get face 'face-defface-spec)
35 (put face 'face-defface-spec spec) 34 (put face 'face-defface-spec spec)
36 (unless (find-face face) 35 (unless (find-face face)
37 ;; If the user has already created the face, respect that. 36 ;; If the user has already created the face, respect that.
38 (let ((value (or (get face 'saved-face) spec)) 37 (let ((value (or (get face 'saved-face) spec))
39 (frames (relevant-custom-frames)) 38 (frames (relevant-custom-frames))
40 frame) 39 frame)
41 ;; Create global face. 40 ;; Create global face.
42 (make-empty-face face) 41 (make-empty-face face)
43 (face-display-set face value nil '(custom)) 42 (face-display-set face value)
44 ;; Create frame local faces 43 ;; Create frame local faces
45 (while frames 44 (while frames
46 (setq frame (car frames) 45 (setq frame (car frames)
47 frames (cdr frames)) 46 frames (cdr frames))
48 (face-display-set face value frame '(custom))) 47 (face-display-set face value frame))
49 (init-face-from-resources face))) 48 (init-face-from-resources face)))
50 (when (and doc (null (face-doc-string face))) 49 (when (and doc (null (face-doc-string face)))
51 (set-face-doc-string face doc)) 50 (set-face-doc-string face doc))
52 (custom-handle-all-keywords face args 'custom-face) 51 (custom-handle-all-keywords face args 'custom-face)
53 (run-hooks 'custom-define-hook)) 52 (run-hooks 'custom-define-hook))
68 :help-echo "\ 67 :help-echo "\
69 Text size (e.g. 9pt or 2mm).") 68 Text size (e.g. 9pt or 2mm).")
70 custom-set-face-font-size custom-face-font-size) 69 custom-set-face-font-size custom-face-font-size)
71 (:family (editable-field :format "Font Family: %v" 70 (:family (editable-field :format "Font Family: %v"
72 :help-echo "\ 71 :help-echo "\
73 Name of font family to use (e.g. times).") 72 Name of font family to use (e.g. times).")
74 custom-set-face-font-family custom-face-font-family) 73 custom-set-face-font-family custom-face-font-family)
75 (:background-pixmap (editable-field :format "Background pixmap: %v" 74 (:background-pixmap (editable-field :format "Background pixmap: %v"
76 :help-echo "\ 75 :help-echo "\
77 Name of background pixmap file.") 76 Name of background pixmap file.")
78 set-face-background-pixmap custom-face-background-pixmap) 77 set-face-background-pixmap custom-face-background-pixmap)
109 be changed. 108 be changed.
110 109
111 The GET function should take two arguments, the face to examine, and 110 The GET function should take two arguments, the face to examine, and
112 optonally the frame where the face should be examined.") 111 optonally the frame where the face should be examined.")
113 112
114 (defun face-custom-attributes-set (face frame tags &rest atts) 113 (defun face-custom-attributes-set (face frame &rest atts)
115 "For FACE on FRAME set the attributes [KEYWORD VALUE].... 114 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
116 Each keyword should be listed in `custom-face-attributes'. 115 Each keyword should be listed in `custom-face-attributes'.
117 116
118 If FRAME is nil, set the default face." 117 If FRAME is nil, set the default face."
119 (while atts 118 (while atts
120 (let* ((name (nth 0 atts)) 119 (let* ((name (nth 0 atts))
121 (value (nth 1 atts)) 120 (value (nth 1 atts))
122 (fun (nth 2 (assq name custom-face-attributes)))) 121 (fun (nth 2 (assq name custom-face-attributes))))
123 (setq atts (cdr (cdr atts))) 122 (setq atts (cdr (cdr atts)))
124 (condition-case nil 123 (condition-case nil
125 (funcall fun face value frame tags) 124 (funcall fun face value frame)
126 (error nil))))) 125 (error nil)))))
127 126
128 (defun face-custom-attributes-get (face frame) 127 (defun face-custom-attributes-get (face frame)
129 "For FACE on FRAME get the attributes [KEYWORD VALUE].... 128 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
130 Each keyword should be listed in `custom-face-attributes'. 129 Each keyword should be listed in `custom-face-attributes'.
156 (get symbol 'face-defface-spec) 155 (get symbol 'face-defface-spec)
157 ;; Attempt to construct it. 156 ;; Attempt to construct it.
158 (list (list t (face-custom-attributes-get 157 (list (list t (face-custom-attributes-get
159 symbol (selected-frame)))))) 158 symbol (selected-frame))))))
160 159
161 (defun custom-set-face-bold (face value &optional frame tags) 160 (defun custom-set-face-bold (face value &optional frame)
162 "Set the bold property of FACE to VALUE." 161 "Set the bold property of FACE to VALUE."
163 (if value 162 (if value
164 (make-face-bold face frame tags) 163 (make-face-bold face frame)
165 (make-face-unbold face frame tags))) 164 (make-face-unbold face frame)))
166 165
167 ;; Really, we should get rid of these font.el dependencies... They 166 ;; Really, we should get rid of these font.el dependencies... They
168 ;; are still presenting a problem with dumping the faces (font.el is 167 ;; are still presenting a problem with dumping the faces (font.el is
169 ;; too bloated for us to dump). I am thinking about hacking up 168 ;; too bloated for us to dump). I am thinking about hacking up
170 ;; font-like functionality myself for the sake of this file. It will 169 ;; font-like functionality myself for the sake of this file. It will
175 (let* ((font (apply 'face-font-name face args)) 174 (let* ((font (apply 'face-font-name face args))
176 ;; Gag 175 ;; Gag
177 (fontobj (font-create-object font))) 176 (fontobj (font-create-object font)))
178 (font-bold-p fontobj))) 177 (font-bold-p fontobj)))
179 178
180 (defun custom-set-face-italic (face value &optional frame tags) 179 (defun custom-set-face-italic (face value &optional frame)
181 "Set the italic property of FACE to VALUE." 180 "Set the italic property of FACE to VALUE."
182 (if value 181 (if value
183 (make-face-italic face frame tags) 182 (make-face-italic face frame)
184 (make-face-unitalic face frame tags))) 183 (make-face-unitalic face frame)))
185 184
186 (defun custom-face-italic (face &rest args) 185 (defun custom-face-italic (face &rest args)
187 "Return non-nil if the font of FACE is italic." 186 "Return non-nil if the font of FACE is italic."
188 (let* ((font (apply 'face-font-name face args)) 187 (let* ((font (apply 'face-font-name face args))
189 ;; Gag 188 ;; Gag
195 (let ((image (apply 'specifier-instance 194 (let ((image (apply 'specifier-instance
196 (face-background-pixmap face) args))) 195 (face-background-pixmap face) args)))
197 (and image 196 (and image
198 (image-instance-file-name image)))) 197 (image-instance-file-name image))))
199 198
200 (defun custom-set-face-font-size (face size &optional locale tags) 199 (defun custom-set-face-font-size (face size &rest args)
201 "Set the font of FACE to SIZE" 200 "Set the font of FACE to SIZE"
202 (let* ((font (apply 'face-font-name face locale)) 201 (let* ((font (apply 'face-font-name face args))
203 ;; Gag 202 ;; Gag
204 (fontobj (font-create-object font))) 203 (fontobj (font-create-object font)))
205 (set-font-size fontobj size) 204 (set-font-size fontobj size)
206 (apply 'font-set-face-font face fontobj locale tags))) 205 (apply 'font-set-face-font face fontobj args)))
207 206
208 (defun custom-face-font-size (face &rest args) 207 (defun custom-face-font-size (face &rest args)
209 "Return the size of the font of FACE as a string." 208 "Return the size of the font of FACE as a string."
210 (let* ((font (apply 'face-font-name face args)) 209 (let* ((font (apply 'face-font-name face args))
211 ;; Gag 210 ;; Gag
212 (fontobj (font-create-object font))) 211 (fontobj (font-create-object font)))
213 (format "%s" (font-size fontobj)))) 212 (format "%s" (font-size fontobj))))
214 213
215 (defun custom-set-face-font-family (face family &optional locale tags) 214 (defun custom-set-face-font-family (face family &rest args)
216 "Set the font of FACE to FAMILY." 215 "Set the font of FACE to FAMILY."
217 (let* ((font (apply 'face-font-name face locale)) 216 (let* ((font (apply 'face-font-name face args))
218 ;; Gag 217 ;; Gag
219 (fontobj (font-create-object font))) 218 (fontobj (font-create-object font)))
220 (set-font-family fontobj family) 219 (set-font-family fontobj family)
221 (apply 'font-set-face-font face fontobj locale tags))) 220 (apply 'font-set-face-font face fontobj args)))
222 221
223 (defun custom-face-font-family (face &rest args) 222 (defun custom-face-font-family (face &rest args)
224 "Return the name of the font family of FACE." 223 "Return the name of the font family of FACE."
225 (let* ((font (apply 'face-font-name face args)) 224 (let* ((font (apply 'face-font-name face args))
226 ;; Gag 225 ;; Gag
232 "Customize the FACE for display types matching DISPLAY, merging 231 "Customize the FACE for display types matching DISPLAY, merging
233 in the new items from PLIST" 232 in the new items from PLIST"
234 (let ((spec (face-spec-update-all-matching (custom-face-get-spec face) 233 (let ((spec (face-spec-update-all-matching (custom-face-get-spec face)
235 display plist))) 234 display plist)))
236 (put face 'customized-face spec) 235 (put face 'customized-face spec)
237 (face-spec-set face spec nil '(custom)))) 236 (face-spec-set face spec)))
238 237
239 ;;; Initializing. 238 ;;; Initializing.
240 239
241 ;;;###autoload 240 ;;;###autoload
242 (defun custom-set-faces (&rest args) 241 (defun custom-set-faces (&rest args)
243 "Initialize faces according to user preferences. 242 "Initialize faces according to user preferences.
244 This asociates the setting with the USER theme.
245 The arguments should be a list where each entry has the form: 243 The arguments should be a list where each entry has the form:
246 244
247 (FACE SPEC [NOW [COMMENT]]) 245 (FACE SPEC [NOW])
248 246
249 SPEC will be stored as the saved value for FACE. If NOW is present 247 SPEC will be stored as the saved value for FACE. If NOW is present
250 and non-nil, FACE will also be created according to SPEC. 248 and non-nil, FACE will also be created according to SPEC.
251 COMMENT is a string comment about FACE.
252 249
253 See `defface' for the format of SPEC." 250 See `defface' for the format of SPEC."
254 (apply #'custom-theme-set-faces 'user args)) 251 (while args
255 252 (let ((entry (car args)))
256 ;;;###autoload 253 (if (listp entry)
257 (defun custom-theme-set-faces (theme &rest args) 254 (let ((face (nth 0 entry))
258 "Initialize faces according to settings specified by args. 255 (spec (nth 1 entry))
259 Records the settings as belonging to THEME. 256 (now (nth 2 entry)))
260
261 See `custom-set-faces' for a description of the arguments ARGS."
262 (custom-check-theme theme)
263 (let ((immediate (get theme 'theme-immediate)))
264 (while args
265 (let ((entry (car args)))
266 (if (listp entry)
267 (let ((face (nth 0 entry))
268 (spec (nth 1 entry))
269 (now (nth 2 entry))
270 (comment (nth 3 entry)))
271 (put face 'saved-face spec)
272 (custom-push-theme 'theme-face face theme 'set spec)
273 (put face 'saved-face-comment comment)
274 (when (or now immediate)
275 (put face 'force-face (if now 'rogue 'immediate)))
276 (when (or now immediate (find-face face))
277 (put face 'face-comment comment)
278 (unless (find-face face)
279 (make-empty-face face))
280 (face-spec-set face spec nil '(custom)))
281 (setq args (cdr args)))
282 ;; Old format, a plist of FACE SPEC pairs.
283 (let ((face (nth 0 args))
284 (spec (nth 1 args)))
285 (put face 'saved-face spec) 257 (put face 'saved-face spec)
286 (custom-push-theme 'theme-face face theme 'set spec)) 258 (when now
287 (setq args (cdr (cdr args)))))))) 259 (put face 'force-face t))
288 260 (when (or now (find-face face))
289 ;;;###autoload
290 (defun custom-theme-face-value (face theme)
291 "Return spec of FACE in THEME if the THEME modifies the
292 FACE. Nil otherwise."
293 (car-safe (custom-theme-value theme (get face 'theme-face))))
294
295 (defun custom-theme-reset-internal-face (face to-theme)
296 (let ((spec (custom-theme-face-value face to-theme))
297 was-in-theme)
298 (setq was-in-theme spec)
299 (setq spec (or spec (get face 'standard-value)))
300 (when spec
301 (put face 'save-face was-in-theme)
302 (when (or (get face 'force-face) (find-face face))
303 (unless (find-face face) 261 (unless (find-face face)
304 (make-empty-face face)) 262 (make-empty-face face))
305 (face-spec-set face spec))) 263 (face-spec-set face spec))
306 spec)) 264 (setq args (cdr args)))
307 265 ;; Old format, a plist of FACE SPEC pairs.
308 ;;;###autoload 266 (let ((face (nth 0 args))
309 (defun custom-theme-reset-faces (theme &rest args) 267 (spec (nth 1 args)))
310 (custom-check-theme theme) 268 (put face 'saved-face spec))
311 "Reset the value of the face to values previously defined. 269 (setq args (cdr (cdr args)))))))
312 Assosiate this setting with THEME.
313
314 ARGS is a list of lists of the form
315
316 (face to-theme)
317
318 This means reset face to its value in to-theme."
319 (mapc #'(lambda (arg)
320 (apply #'custom-theme-reset-internal-face arg)
321 (custom-push-theme (car arg) 'theme-face theme 'reset (cadr arg)))
322 args))
323
324 ;;;###autoload
325 (defun custom-reset-faces (&rest args)
326 "Reset the value of the face to values previously defined.
327 Assosiate this setting with the 'user' theme.
328
329 ARGS is defined as for `custom-theme-reset-faces'"
330 (apply #'custom-theme-reset-faces 'user args))
331
332 270
333 ;;; The End. 271 ;;; The End.
334 272
335 (provide 'cus-face) 273 (provide 'cus-face)
336 274