/[emacs]/emacs/lisp/cus-face.el
ViewVC logotype

Diff of /emacs/lisp/cus-face.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.29 by rms, Wed Apr 10 14:45:37 2002 UTC revision 1.29.2.1 by miles, Fri Apr 4 06:20:01 2003 UTC
# Line 1  Line 1 
1  ;;; cus-face.el --- customization support for faces  ;;; cus-face.el --- customization support for faces
2  ;;  ;;
3  ;; Copyright (C) 1996, 1997, 1999, 2000 Free Software Foundation, Inc.  ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
4  ;;  ;;
5  ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>  ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6  ;; Keywords: help, faces  ;; Keywords: help, faces
 ;; Version: Emacs  
7    
8  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
9    
# Line 37  Line 36 
36  (defun custom-declare-face (face spec doc &rest args)  (defun custom-declare-face (face spec doc &rest args)
37    "Like `defface', but FACE is evaluated as a normal argument."    "Like `defface', but FACE is evaluated as a normal argument."
38    (unless (get face 'face-defface-spec)    (unless (get face 'face-defface-spec)
     (put face 'face-defface-spec spec)  
39      (when (fboundp 'facep)      (when (fboundp 'facep)
40        (unless (facep face)        (unless (facep face)
41          ;; If the user has already created the face, respect that.          ;; If the user has already created the face, respect that.
# Line 46  Line 44 
44                frame)                frame)
45            ;; Create global face.            ;; Create global face.
46            (make-empty-face face)            (make-empty-face face)
47            ;; Create frame local faces            ;; Create frame-local faces
48            (while frames            (while frames
49              (setq frame (car frames)              (setq frame (car frames)
50                    frames (cdr frames))                    frames (cdr frames))
# Line 54  Line 52 
52          ;; When making a face after frames already exist          ;; When making a face after frames already exist
53          (if (memq window-system '(x w32))          (if (memq window-system '(x w32))
54              (make-face-x-resource-internal face))))              (make-face-x-resource-internal face))))
55        ;; Don't record SPEC until we see it causes no errors.
56        (put face 'face-defface-spec spec)
57      (when (and doc (null (face-documentation face)))      (when (and doc (null (face-documentation face)))
58        (set-face-documentation face (purecopy doc)))        (set-face-documentation face (purecopy doc)))
59      (custom-handle-all-keywords face args 'custom-face)      (custom-handle-all-keywords face args 'custom-face)
# Line 66  Line 66 
66    '((:family    '((:family
67       (string :tag "Font Family"       (string :tag "Font Family"
68               :help-echo "Font family or fontset alias name."))               :help-echo "Font family or fontset alias name."))
69        
70      (:width      (:width
71       (choice :tag "Width"       (choice :tag "Width"
72               :help-echo "Font width."               :help-echo "Font width."
# Line 86  Line 86 
86               (const :tag "ultracondensed" ultra-condensed)               (const :tag "ultracondensed" ultra-condensed)
87               (const :tag "ultraexpanded" ultra-expanded)               (const :tag "ultraexpanded" ultra-expanded)
88               (const :tag "wide" extra-expanded)))               (const :tag "wide" extra-expanded)))
89        
90      (:height      (:height
91       (choice :tag "Height"       (choice :tag "Height"
92               :help-echo "Face's font height."               :help-echo "Face's font height."
# Line 113  Line 113 
113               (const :tag "semilight" semi-light)               (const :tag "semilight" semi-light)
114               (const :tag "ultralight" ultra-light)               (const :tag "ultralight" ultra-light)
115               (const :tag "ultrabold" ultra-bold)))               (const :tag "ultrabold" ultra-bold)))
116        
117      (:slant      (:slant
118       (choice :tag "Slant"       (choice :tag "Slant"
119               :help-echo "Font slant."               :help-echo "Font slant."
# Line 121  Line 121 
121               (const :tag "italic" italic)               (const :tag "italic" italic)
122               (const :tag "oblique" oblique)               (const :tag "oblique" oblique)
123               (const :tag "normal" normal)))               (const :tag "normal" normal)))
124        
125      (:underline      (:underline
126       (choice :tag "Underline"       (choice :tag "Underline"
127               :help-echo "Control text underlining."               :help-echo "Control text underlining."
128               (const :tag "Off" nil)               (const :tag "Off" nil)
129               (const :tag "On" t)               (const :tag "On" t)
130               (color :tag "Colored")))               (color :tag "Colored")))
131        
132      (:overline      (:overline
133       (choice :tag "Overline"       (choice :tag "Overline"
134               :help-echo "Control text overlining."               :help-echo "Control text overlining."
135               (const :tag "Off" nil)               (const :tag "Off" nil)
136               (const :tag "On" t)               (const :tag "On" t)
137               (color :tag "Colored")))               (color :tag "Colored")))
138        
139      (:strike-through      (:strike-through
140       (choice :tag "Strike-through"       (choice :tag "Strike-through"
141               :help-echo "Control text strike-through."               :help-echo "Control text strike-through."
142               (const :tag "Off" nil)               (const :tag "Off" nil)
143               (const :tag "On" t)               (const :tag "On" t)
144               (color :tag "Colored")))               (color :tag "Colored")))
145        
146      (:box      (:box
147       ;; Fixme: this can probably be done better.       ;; Fixme: this can probably be done better.
148       (choice :tag "Box around text"       (choice :tag "Box around text"
# Line 190  Line 190 
190                       (nconc (and lwidth `(:line-width ,lwidth))                       (nconc (and lwidth `(:line-width ,lwidth))
191                              (and color  `(:color ,color))                              (and color  `(:color ,color))
192                              (and style  `(:style ,style)))))))))                              (and style  `(:style ,style)))))))))
193        
194      (:inverse-video      (:inverse-video
195       (choice :tag "Inverse-video"       (choice :tag "Inverse-video"
196               :help-echo "Control whether text should be in inverse-video."               :help-echo "Control whether text should be in inverse-video."
197               (const :tag "Off" nil)               (const :tag "Off" nil)
198               (const :tag "On" t)))               (const :tag "On" t)))
199        
200      (:foreground      (:foreground
201       (color :tag "Foreground"       (color :tag "Foreground"
202              :help-echo "Set foreground color."))              :help-echo "Set foreground color."))
203        
204      (:background      (:background
205       (color :tag "Background"       (color :tag "Background"
206              :help-echo "Set background color."))              :help-echo "Set background color."))
207        
208      (:stipple      (:stipple
209       (choice :tag "Stipple"       (choice :tag "Stipple"
210               :help-echo "Background bit-mask"               :help-echo "Background bit-mask"
# Line 230  Line 230 
230         (if (and (consp cus-value) (null (cdr cus-value)))         (if (and (consp cus-value) (null (cdr cus-value)))
231             (car cus-value)             (car cus-value)
232           cus-value))))           cus-value))))
233          
234    "Alist of face attributes.    "Alist of face attributes.
235    
236  The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),  The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER),
# Line 248  The POST-FILTER should also take a singl Line 248  The POST-FILTER should also take a singl
248  being customized, and should return a value suitable for setting the  being customized, and should return a value suitable for setting the
249  given face attribute.")  given face attribute.")
250    
   
251  (defun custom-face-attributes-get (face frame)  (defun custom-face-attributes-get (face frame)
252    "For FACE on FRAME, return an alternating list describing its attributes.    "For FACE on FRAME, return an alternating list describing its attributes.
253  The list has the form (KEYWORD VALUE KEYWORD VALUE...).  The list has the form (KEYWORD VALUE KEYWORD VALUE...).
# Line 271  If FRAME is nil, use the global defaults Line 270  If FRAME is nil, use the global defaults
270  ;;;###autoload  ;;;###autoload
271  (defun custom-set-faces (&rest args)  (defun custom-set-faces (&rest args)
272    "Initialize faces according to user preferences.    "Initialize faces according to user preferences.
273    This associates the settings with the `user' theme.
274  The arguments should be a list where each entry has the form:  The arguments should be a list where each entry has the form:
275    
276    (FACE SPEC [NOW [COMMENT]])    (FACE SPEC [NOW [COMMENT]])
277    
278  SPEC is stored as the saved value for FACE.  SPEC is stored as the saved value for FACE, as well as the value for the
279    `user' theme.  The `user' theme is one of the default themes known to Emacs.
280    See `custom-known-themes' for more information on the known themes.
281    See `custom-theme-set-faces' for more information on the interplay
282    between themes and faces.
283    See `defface' for the format of SPEC.
284    
285    If NOW is present and non-nil, FACE is created now, according to SPEC.
286    COMMENT is a string comment about FACE."
287      (apply 'custom-theme-set-faces 'user args))
288    
289    (defun custom-theme-set-faces (theme &rest args)
290      "Initialize faces for theme THEME.
291    The arguments should be a list where each entry has the form:
292    
293      (FACE SPEC [NOW [COMMENT]])
294    
295    SPEC is stored as the saved value for FACE, as well as the value for the
296    `user' theme.  The `user' theme is one of the default themes known to Emacs.
297    See `custom-known-themes' for more information on the known themes.
298    See `custom-theme-set-faces' for more information on the interplay
299    between themes and faces.
300    See `defface' for the format of SPEC.
301    
302  If NOW is present and non-nil, FACE is created now, according to SPEC.  If NOW is present and non-nil, FACE is created now, according to SPEC.
303  COMMENT is a string comment about FACE.  COMMENT is a string comment about FACE.
304    
305  See `defface' for the format of SPEC."  Several properties of THEME and FACE are used in the process:
306    (while args  
307      (let ((entry (car args)))  If THEME property `theme-immediate' is non-nil, this is equivalent of
308        (if (listp entry)  providing the NOW argument to all faces in the argument list: FACE is
309            (let ((face (nth 0 entry))  created now.  The only difference is FACE property `force-face': if NOW
310                  (spec (nth 1 entry))  is non-nil, FACE property `force-face' is set to the symbol `rogue', else
311                  (now (nth 2 entry))  if THEME property `theme-immediate' is non-nil, FACE property `force-face'
312                  (comment (nth 3 entry)))  is set to the symbol `immediate'.
313              (put face 'saved-face spec)  
314              (put face 'saved-face-comment comment)  SPEC itself is saved in FACE property `saved-face' and it is stored in
315              (when now  FACE's list property `theme-face' \(using `custom-push-theme')."
316                (put face 'force-face t))    (custom-check-theme theme)
317              (when (or now (facep face))    (let ((immediate (get theme 'theme-immediate)))
318                (put face 'face-comment comment)      (while args
319                (make-empty-face face)        (let ((entry (car args)))
320                (face-spec-set face spec))          (if (listp entry)
321                (let ((face (nth 0 entry))
322                      (spec (nth 1 entry))
323                      (now (nth 2 entry))
324                      (comment (nth 3 entry)))
325                  (put face 'saved-face spec)
326                  (put face 'saved-face-comment comment)
327                  (custom-push-theme 'theme-face face theme 'set spec)
328                  (when (or now immediate)
329                    (put face 'force-face (if now 'rogue 'immediate)))
330                  (when (or now immediate (facep face))
331                    (unless (facep face)
332                      (make-empty-face face))
333                    (put face 'face-comment comment)
334                    (face-spec-set face spec))
335              (setq args (cdr args)))              (setq args (cdr args)))
336          ;; Old format, a plist of FACE SPEC pairs.          ;; Old format, a plist of FACE SPEC pairs.
337          (let ((face (nth 0 args))          (let ((face (nth 0 args))
338                (spec (nth 1 args)))                (spec (nth 1 args)))
339            (put face 'saved-face spec))            (put face 'saved-face spec)
340          (setq args (cdr (cdr args)))))))            (custom-push-theme 'theme-face face theme 'set spec))
341            (setq args (cdr (cdr args))))))))
342    
343    ;;;###autoload
344    (defun custom-theme-face-value (face theme)
345      "Return spec of FACE in THEME if THEME modifies FACE.
346    Value is nil otherwise.  The association between theme and spec for FACE
347    is stored in FACE's property `theme-face'.  The appropriate face
348    is retrieved using `custom-theme-value'."
349      ;; Returns car because the value is stored inside a one element list
350      (car-safe (custom-theme-value theme (get face 'theme-face))))
351    
352    (defun custom-theme-reset-internal-face (face to-theme)
353      "Reset FACE to the value defined by TO-THEME.
354    If FACE is not defined in TO-THEME, reset FACE to the standard
355    value.  See `custom-theme-face-value'.  The standard value is
356    stored in SYMBOL's property `face-defface-spec' by `defface'."
357      (let ((spec (custom-theme-face-value face to-theme))
358            was-in-theme)
359        (setq was-in-theme spec)
360        (setq spec (or spec (get face 'face-defface-spec)))
361        (when spec
362          (put face 'save-face was-in-theme)
363          (when (or (get face 'force-face) (facep face))
364                  (unless (facep face)
365                    (make-empty-face face))
366                  (face-spec-set face spec)))
367        spec))
368    
369    ;;;###autoload
370    (defun custom-theme-reset-faces (theme &rest args)
371      "Reset the value of the face to values previously defined.
372    Associate this setting with THEME.
373    
374    ARGS is a list of lists of the form
375    
376        (FACE TO-THEME)
377    
378    This means reset FACE to its value in TO-THEME."
379      (custom-check-theme theme)
380      (mapcar '(lambda (arg)
381                 (apply 'custom-theme-reset-internal-face arg)
382                 (custom-push-theme 'theme-face (car arg) theme 'reset (cadr arg)))
383              args))
384    
385    ;;;###autoload
386    (defun custom-reset-faces (&rest args)
387      "Reset the value of the face to values previously saved.
388    This is the setting assosiated the `user' theme.
389    
390    ARGS is defined as for `custom-theme-reset-faces'"
391      (apply 'custom-theme-reset-faces 'user args))
392    
393  ;;; The End.  ;;; The End.
394    

Legend:
Removed from v.1.29  
changed lines
  Added in v.1.29.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26