Mercurial > hg > xemacs-beta

comparison lisp/cus-face.el @ 416:ebe98a74bd68 r21-2-16

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-16
author cvs
date Mon, 13 Aug 2007 11:22:23 +0200
parents 697ef44129c6
children 41dbb7a9d5f2
comparison
equal deleted inserted replaced
415:a27f76b40c83 416:ebe98a74bd68
37 (let ((value (or (get face 'saved-face) spec)) 37 (let ((value (or (get face 'saved-face) spec))
38 (frames (relevant-custom-frames)) 38 (frames (relevant-custom-frames))
39 frame) 39 frame)
40 ;; Create global face. 40 ;; Create global face.
41 (make-empty-face face) 41 (make-empty-face face)
42 (face-display-set face value) 42 (face-display-set face value nil '(custom))
43 ;; Create frame local faces 43 ;; Create frame local faces
44 (while frames 44 (while frames
45 (setq frame (car frames) 45 (setq frame (car frames)
46 frames (cdr frames)) 46 frames (cdr frames))
47 (face-display-set face value frame)) 47 (face-display-set face value frame '(custom)))
48 (init-face-from-resources face))) 48 (init-face-from-resources face)))
49 (when (and doc (null (face-doc-string face))) 49 (when (and doc (null (face-doc-string face)))
50 (set-face-doc-string face doc)) 50 (set-face-doc-string face doc))
51 (custom-handle-all-keywords face args 'custom-face) 51 (custom-handle-all-keywords face args 'custom-face)
52 (run-hooks 'custom-define-hook)) 52 (run-hooks 'custom-define-hook))
108 be changed. 108 be changed.
109 109
110 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
111 optonally the frame where the face should be examined.") 111 optonally the frame where the face should be examined.")
112 112
113 (defun face-custom-attributes-set (face frame &rest atts) 113 (defun face-custom-attributes-set (face frame tags &rest atts)
114 "For FACE on FRAME set the attributes [KEYWORD VALUE].... 114 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
115 Each keyword should be listed in `custom-face-attributes'. 115 Each keyword should be listed in `custom-face-attributes'.
116 116
117 If FRAME is nil, set the default face." 117 If FRAME is nil, set the default face."
118 (while atts 118 (while atts
119 (let* ((name (nth 0 atts)) 119 (let* ((name (nth 0 atts))
120 (value (nth 1 atts)) 120 (value (nth 1 atts))
121 (fun (nth 2 (assq name custom-face-attributes)))) 121 (fun (nth 2 (assq name custom-face-attributes))))
122 (setq atts (cdr (cdr atts))) 122 (setq atts (cdr (cdr atts)))
123 (condition-case nil 123 (condition-case nil
124 (funcall fun face value frame) 124 (funcall fun face value frame tags)
125 (error nil))))) 125 (error nil)))))
126 126
127 (defun face-custom-attributes-get (face frame) 127 (defun face-custom-attributes-get (face frame)
128 "For FACE on FRAME get the attributes [KEYWORD VALUE].... 128 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
129 Each keyword should be listed in `custom-face-attributes'. 129 Each keyword should be listed in `custom-face-attributes'.
155 (get symbol 'face-defface-spec) 155 (get symbol 'face-defface-spec)
156 ;; Attempt to construct it. 156 ;; Attempt to construct it.
157 (list (list t (face-custom-attributes-get 157 (list (list t (face-custom-attributes-get
158 symbol (selected-frame)))))) 158 symbol (selected-frame))))))
159 159
160 (defun custom-set-face-bold (face value &optional frame) 160 (defun custom-set-face-bold (face value &optional frame tags)
161 "Set the bold property of FACE to VALUE." 161 "Set the bold property of FACE to VALUE."
162 (if value 162 (if value
163 (make-face-bold face frame) 163 (make-face-bold face frame tags)
164 (make-face-unbold face frame))) 164 (make-face-unbold face frame tags)))
165 165
166 ;; Really, we should get rid of these font.el dependencies... They 166 ;; Really, we should get rid of these font.el dependencies... They
167 ;; 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
168 ;; 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
169 ;; 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
174 (let* ((font (apply 'face-font-name face args)) 174 (let* ((font (apply 'face-font-name face args))
175 ;; Gag 175 ;; Gag
176 (fontobj (font-create-object font))) 176 (fontobj (font-create-object font)))
177 (font-bold-p fontobj))) 177 (font-bold-p fontobj)))
178 178
179 (defun custom-set-face-italic (face value &optional frame) 179 (defun custom-set-face-italic (face value &optional frame tags)
180 "Set the italic property of FACE to VALUE." 180 "Set the italic property of FACE to VALUE."
181 (if value 181 (if value
182 (make-face-italic face frame) 182 (make-face-italic face frame tags)
183 (make-face-unitalic face frame))) 183 (make-face-unitalic face frame tags)))
184 184
185 (defun custom-face-italic (face &rest args) 185 (defun custom-face-italic (face &rest args)
186 "Return non-nil if the font of FACE is italic." 186 "Return non-nil if the font of FACE is italic."
187 (let* ((font (apply 'face-font-name face args)) 187 (let* ((font (apply 'face-font-name face))
188 ;; Gag 188 ;; Gag
189 (fontobj (font-create-object font))) 189 (fontobj (font-create-object font)))
190 (font-italic-p fontobj))) 190 (font-italic-p fontobj)))
191 191
192 (defun custom-face-background-pixmap (face &rest args) 192 (defun custom-face-background-pixmap (face &rest args)
194 (let ((image (apply 'specifier-instance 194 (let ((image (apply 'specifier-instance
195 (face-background-pixmap face) args))) 195 (face-background-pixmap face) args)))
196 (and image 196 (and image
197 (image-instance-file-name image)))) 197 (image-instance-file-name image))))
198 198
199 (defun custom-set-face-font-size (face size &rest args) 199 (defun custom-set-face-font-size (face size &optional locale tags)
200 "Set the font of FACE to SIZE" 200 "Set the font of FACE to SIZE"
201 (let* ((font (apply 'face-font-name face args)) 201 (let* ((font (apply 'face-font-name face locale))
202 ;; Gag 202 ;; Gag
203 (fontobj (font-create-object font))) 203 (fontobj (font-create-object font)))
204 (set-font-size fontobj size) 204 (set-font-size fontobj size)
205 (apply 'font-set-face-font face fontobj args))) 205 (apply 'font-set-face-font face fontobj locale tags)))
206 206
207 (defun custom-face-font-size (face &rest args) 207 (defun custom-face-font-size (face &rest args)
208 "Return the size of the font of FACE as a string." 208 "Return the size of the font of FACE as a string."
209 (let* ((font (apply 'face-font-name face args)) 209 (let* ((font (apply 'face-font-name face args))
210 ;; Gag 210 ;; Gag
211 (fontobj (font-create-object font))) 211 (fontobj (font-create-object font)))
212 (format "%s" (font-size fontobj)))) 212 (format "%s" (font-size fontobj))))
213 213
214 (defun custom-set-face-font-family (face family &rest args) 214 (defun custom-set-face-font-family (face family &optional locale tags)
215 "Set the font of FACE to FAMILY." 215 "Set the font of FACE to FAMILY."
216 (let* ((font (apply 'face-font-name face args)) 216 (let* ((font (apply 'face-font-name face locale))
217 ;; Gag 217 ;; Gag
218 (fontobj (font-create-object font))) 218 (fontobj (font-create-object font)))
219 (set-font-family fontobj family) 219 (set-font-family fontobj family)
220 (apply 'font-set-face-font face fontobj args))) 220 (apply 'font-set-face-font face fontobj locale tags)))
221 221
222 (defun custom-face-font-family (face &rest args) 222 (defun custom-face-font-family (face &rest args)
223 "Return the name of the font family of FACE." 223 "Return the name of the font family of FACE."
224 (let* ((font (apply 'face-font-name face args)) 224 (let* ((font (apply 'face-font-name face args))
225 ;; Gag 225 ;; Gag
231 "Customize the FACE for display types matching DISPLAY, merging 231 "Customize the FACE for display types matching DISPLAY, merging
232 in the new items from PLIST" 232 in the new items from PLIST"
233 (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)
234 display plist))) 234 display plist)))
235 (put face 'customized-face spec) 235 (put face 'customized-face spec)
236 (face-spec-set face spec))) 236 (face-spec-set face spec nil '(custom))))
237 237
238 ;;; Initializing. 238 ;;; Initializing.
239 239
240 ;;;###autoload 240 ;;;###autoload
241 (defun custom-set-faces (&rest args) 241 (defun custom-set-faces (&rest args)
258 (when now 258 (when now
259 (put face 'force-face t)) 259 (put face 'force-face t))
260 (when (or now (find-face face)) 260 (when (or now (find-face face))
261 (unless (find-face face) 261 (unless (find-face face)
262 (make-empty-face face)) 262 (make-empty-face face))
263 (face-spec-set face spec)) 263 (face-spec-set face spec nil '(custom)))
264 (setq args (cdr args))) 264 (setq args (cdr args)))
265 ;; Old format, a plist of FACE SPEC pairs. 265 ;; Old format, a plist of FACE SPEC pairs.
266 (let ((face (nth 0 args)) 266 (let ((face (nth 0 args))
267 (spec (nth 1 args))) 267 (spec (nth 1 args)))
268 (put face 'saved-face spec)) 268 (put face 'saved-face spec))