428
+ − 1 ;;; cus-face.el -- Support for Custom faces.
+ − 2 ;;
+ − 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
+ − 4 ;;
+ − 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+ − 6 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
+ − 7 ;; Keywords: help, faces
+ − 8 ;; Version: 1.9960-x
+ − 9 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
+ − 10
+ − 11 ;;; Commentary:
+ − 12 ;;
+ − 13 ;; See `custom.el'.
+ − 14
+ − 15 ;; This file should probably be dissolved, and code moved to faces.el,
+ − 16 ;; like Stallman did.
+ − 17
+ − 18 ;;; Code:
+ − 19
+ − 20 (require 'custom)
+ − 21
+ − 22 ;; To elude the warnings for font functions.
+ − 23 (eval-when-compile
+ − 24 (require 'font))
+ − 25
+ − 26 ;;; Declaring a face.
+ − 27
+ − 28 ;;;###autoload
+ − 29 (defun custom-declare-face (face spec doc &rest args)
+ − 30 "Like `defface', but FACE is evaluated as a normal argument."
+ − 31 ;; (when (fboundp 'pureload)
+ − 32 ;; (error "Attempt to declare a face during dump"))
+ − 33 ;; #### should we possibly reset force-face here?
+ − 34 (unless (get face 'face-defface-spec)
+ − 35 (put face 'face-defface-spec spec)
+ − 36 (unless (find-face face)
+ − 37 ;; If the user has already created the face, respect that.
+ − 38 (let ((value (or (get face 'saved-face) spec))
+ − 39 (frames (relevant-custom-frames))
+ − 40 frame)
+ − 41 ;; Create global face.
+ − 42 (make-empty-face face)
+ − 43 (face-display-set face value nil '(custom))
+ − 44 ;; Create frame local faces
+ − 45 (while frames
+ − 46 (setq frame (car frames)
+ − 47 frames (cdr frames))
+ − 48 (face-display-set face value frame '(custom)))
+ − 49 (init-face-from-resources face)))
+ − 50 (when (and doc (null (face-doc-string face)))
+ − 51 (set-face-doc-string face doc))
+ − 52 (custom-handle-all-keywords face args 'custom-face)
+ − 53 (run-hooks 'custom-define-hook))
+ − 54 face)
+ − 55
+ − 56 ;;; Font Attributes.
+ − 57
444
+ − 58 ;; Consider adding the stuff in the XML font model here.
428
+ − 59 (defconst custom-face-attributes
+ − 60 '((:foreground (color :tag "Foreground"
+ − 61 :value ""
+ − 62 :help-echo "Set foreground color.")
+ − 63 set-face-foreground face-foreground-name)
+ − 64 (:background (color :tag "Background"
+ − 65 :value ""
+ − 66 :help-echo "Set background color.")
+ − 67 set-face-background face-background-name)
+ − 68 (:size (editable-field :format "Size: %v"
+ − 69 :help-echo "\
+ − 70 Text size (e.g. 9pt or 2mm).")
+ − 71 custom-set-face-font-size custom-face-font-size)
+ − 72 (:family (editable-field :format "Font Family: %v"
+ − 73 :help-echo "\
+ − 74 Name of font family to use (e.g. times).")
+ − 75 custom-set-face-font-family custom-face-font-family)
+ − 76 (:background-pixmap (editable-field :format "Background pixmap: %v"
+ − 77 :help-echo "\
+ − 78 Name of background pixmap file.")
+ − 79 set-face-background-pixmap custom-face-background-pixmap)
+ − 80 (:dim (toggle :format "%[Dim%]: %v\n"
+ − 81 :help-echo "Control whether the text should be dimmed.")
+ − 82 set-face-dim-p face-dim-p)
+ − 83 (:bold (toggle :format "%[Bold%]: %v\n"
+ − 84 :help-echo "Control whether a bold font should be used.")
+ − 85 custom-set-face-bold custom-face-bold)
+ − 86 (:italic (toggle :format "%[Italic%]: %v\n"
+ − 87 :help-echo "\
+ − 88 Control whether an italic font should be used.")
+ − 89 custom-set-face-italic custom-face-italic)
+ − 90 (:underline (toggle :format "%[Underline%]: %v\n"
+ − 91 :help-echo "\
+ − 92 Control whether the text should be underlined.")
+ − 93 set-face-underline-p face-underline-p)
+ − 94 (:strikethru (toggle :format "%[Strikethru%]: %v\n"
+ − 95 :help-echo "\
+ − 96 Control whether the text should be strikethru.")
+ − 97 set-face-strikethru-p face-strikethru-p)
+ − 98 (:inverse-video (toggle :format "%[Inverse Video%]: %v\n"
+ − 99 :help-echo "\
+ − 100 Control whether the text should be inverted. Works only on TTY-s")
+ − 101 set-face-reverse-p face-reverse-p))
444
+ − 102 "Alist of face attributes.
428
+ − 103
444
+ − 104 The elements are lists of the form (KEY TYPE SET GET) where:
+ − 105 KEY is a symbol identifying the attribute.
+ − 106 TYPE is a widget type for editing the attribute.
+ − 107 SET is a function for setting the attribute value.
+ − 108 GET is a function for getting the attribute value.
428
+ − 109
444
+ − 110 The SET function should take three arguments: the face to modify, the
428
+ − 111 value of the attribute, and optionally the frame where the face should
+ − 112 be changed.
+ − 113
+ − 114 The GET function should take two arguments, the face to examine, and
444
+ − 115 optionally the frame where the face should be examined.")
428
+ − 116
+ − 117 (defun face-custom-attributes-set (face frame tags &rest atts)
+ − 118 "For FACE on FRAME set the attributes [KEYWORD VALUE]....
+ − 119 Each keyword should be listed in `custom-face-attributes'.
+ − 120
+ − 121 If FRAME is nil, set the default face."
+ − 122 (while atts
+ − 123 (let* ((name (nth 0 atts))
+ − 124 (value (nth 1 atts))
+ − 125 (fun (nth 2 (assq name custom-face-attributes))))
+ − 126 (setq atts (cdr (cdr atts)))
+ − 127 (condition-case nil
+ − 128 (funcall fun face value frame tags)
+ − 129 (error nil)))))
+ − 130
+ − 131 (defun face-custom-attributes-get (face frame)
+ − 132 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
+ − 133 Each keyword should be listed in `custom-face-attributes'.
+ − 134
+ − 135 If FRAME is nil, use the default face."
+ − 136 (condition-case nil
+ − 137 ;; Attempt to get `font.el' from w3.
+ − 138 (require 'font)
+ − 139 (error nil))
+ − 140 (let ((atts custom-face-attributes)
+ − 141 att result get)
+ − 142 (while atts
+ − 143 (setq att (car atts)
+ − 144 atts (cdr atts)
+ − 145 get (nth 3 att))
+ − 146 (condition-case nil
+ − 147 ;; This may fail if w3 doesn't exist.
+ − 148 (when get
+ − 149 (let ((answer (funcall get face frame)))
+ − 150 (unless (equal answer (funcall get 'default frame))
+ − 151 (when (widget-apply (nth 1 att) :match answer)
+ − 152 (setq result (cons (nth 0 att) (cons answer result)))))))
+ − 153 (error nil)))
+ − 154 result))
+ − 155
+ − 156 (defsubst custom-face-get-spec (symbol)
+ − 157 (or (get symbol 'customized-face)
+ − 158 (get symbol 'saved-face)
+ − 159 (get symbol 'face-defface-spec)
+ − 160 ;; Attempt to construct it.
+ − 161 (list (list t (face-custom-attributes-get
+ − 162 symbol (selected-frame))))))
+ − 163
+ − 164 (defun custom-set-face-bold (face value &optional frame tags)
+ − 165 "Set the bold property of FACE to VALUE."
+ − 166 (if value
+ − 167 (make-face-bold face frame tags)
+ − 168 (make-face-unbold face frame tags)))
+ − 169
+ − 170 ;; Really, we should get rid of these font.el dependencies... They
+ − 171 ;; are still presenting a problem with dumping the faces (font.el is
+ − 172 ;; too bloated for us to dump). I am thinking about hacking up
+ − 173 ;; font-like functionality myself for the sake of this file. It will
+ − 174 ;; probably be to-the-point and more efficient.
+ − 175
+ − 176 (defun custom-face-bold (face &rest args)
+ − 177 "Return non-nil if the font of FACE is bold."
+ − 178 (let* ((font (apply 'face-font-name face args))
+ − 179 ;; Gag
+ − 180 (fontobj (font-create-object font)))
+ − 181 (font-bold-p fontobj)))
+ − 182
+ − 183 (defun custom-set-face-italic (face value &optional frame tags)
+ − 184 "Set the italic property of FACE to VALUE."
+ − 185 (if value
+ − 186 (make-face-italic face frame tags)
+ − 187 (make-face-unitalic face frame tags)))
+ − 188
+ − 189 (defun custom-face-italic (face &rest args)
+ − 190 "Return non-nil if the font of FACE is italic."
+ − 191 (let* ((font (apply 'face-font-name face args))
+ − 192 ;; Gag
+ − 193 (fontobj (font-create-object font)))
+ − 194 (font-italic-p fontobj)))
+ − 195
+ − 196 (defun custom-face-background-pixmap (face &rest args)
+ − 197 "Return the name of the background pixmap file used for FACE."
444
+ − 198 (let ((image (apply 'specifier-instance
428
+ − 199 (face-background-pixmap face) args)))
444
+ − 200 (and image
428
+ − 201 (image-instance-file-name image))))
+ − 202
+ − 203 (defun custom-set-face-font-size (face size &optional locale tags)
444
+ − 204 "Set the font of FACE to SIZE."
428
+ − 205 (let* ((font (apply 'face-font-name face locale))
+ − 206 ;; Gag
+ − 207 (fontobj (font-create-object font)))
+ − 208 (set-font-size fontobj size)
+ − 209 (apply 'font-set-face-font face fontobj locale tags)))
+ − 210
+ − 211 (defun custom-face-font-size (face &rest args)
+ − 212 "Return the size of the font of FACE as a string."
+ − 213 (let* ((font (apply 'face-font-name face args))
+ − 214 ;; Gag
+ − 215 (fontobj (font-create-object font)))
+ − 216 (format "%s" (font-size fontobj))))
+ − 217
+ − 218 (defun custom-set-face-font-family (face family &optional locale tags)
+ − 219 "Set the font of FACE to FAMILY."
+ − 220 (let* ((font (apply 'face-font-name face locale))
+ − 221 ;; Gag
+ − 222 (fontobj (font-create-object font)))
+ − 223 (set-font-family fontobj family)
+ − 224 (apply 'font-set-face-font face fontobj locale tags)))
+ − 225
+ − 226 (defun custom-face-font-family (face &rest args)
+ − 227 "Return the name of the font family of FACE."
+ − 228 (let* ((font (apply 'face-font-name face args))
+ − 229 ;; Gag
+ − 230 (fontobj (font-create-object font)))
+ − 231 (font-family fontobj)))
+ − 232
+ − 233 ;;;###autoload
+ − 234 (defun custom-set-face-update-spec (face display plist)
+ − 235 "Customize the FACE for display types matching DISPLAY, merging
444
+ − 236 in the new items from PLIST."
428
+ − 237 (let ((spec (face-spec-update-all-matching (custom-face-get-spec face)
+ − 238 display plist)))
+ − 239 (put face 'customized-face spec)
+ − 240 (face-spec-set face spec nil '(custom))))
+ − 241
+ − 242 ;;; Initializing.
+ − 243
+ − 244 ;;;###autoload
+ − 245 (defun custom-set-faces (&rest args)
+ − 246 "Initialize faces according to user preferences.
+ − 247 This asociates the setting with the USER theme.
+ − 248 The arguments should be a list where each entry has the form:
+ − 249
+ − 250 (FACE SPEC [NOW [COMMENT]])
+ − 251
+ − 252 SPEC will be stored as the saved value for FACE. If NOW is present
+ − 253 and non-nil, FACE will also be created according to SPEC.
+ − 254 COMMENT is a string comment about FACE.
+ − 255
+ − 256 See `defface' for the format of SPEC."
+ − 257 (apply #'custom-theme-set-faces 'user args))
+ − 258
+ − 259 ;;;###autoload
+ − 260 (defun custom-theme-set-faces (theme &rest args)
+ − 261 "Initialize faces according to settings specified by args.
+ − 262 Records the settings as belonging to THEME.
+ − 263
+ − 264 See `custom-set-faces' for a description of the arguments ARGS."
+ − 265 (custom-check-theme theme)
+ − 266 (let ((immediate (get theme 'theme-immediate)))
+ − 267 (while args
+ − 268 (let ((entry (car args)))
+ − 269 (if (listp entry)
+ − 270 (let ((face (nth 0 entry))
+ − 271 (spec (nth 1 entry))
+ − 272 (now (nth 2 entry))
+ − 273 (comment (nth 3 entry)))
+ − 274 (put face 'saved-face spec)
+ − 275 (custom-push-theme 'theme-face face theme 'set spec)
+ − 276 (put face 'saved-face-comment comment)
+ − 277 (when (or now immediate)
+ − 278 (put face 'force-face (if now 'rogue 'immediate)))
+ − 279 (when (or now immediate (find-face face))
+ − 280 (put face 'face-comment comment)
+ − 281 (unless (find-face face)
+ − 282 (make-empty-face face))
+ − 283 (face-spec-set face spec nil '(custom)))
+ − 284 (setq args (cdr args)))
+ − 285 ;; Old format, a plist of FACE SPEC pairs.
+ − 286 (let ((face (nth 0 args))
+ − 287 (spec (nth 1 args)))
+ − 288 (put face 'saved-face spec)
+ − 289 (custom-push-theme 'theme-face face theme 'set spec))
+ − 290 (setq args (cdr (cdr args))))))))
+ − 291
+ − 292 ;;;###autoload
+ − 293 (defun custom-theme-face-value (face theme)
+ − 294 "Return spec of FACE in THEME if the THEME modifies the
+ − 295 FACE. Nil otherwise."
+ − 296 (car-safe (custom-theme-value theme (get face 'theme-face))))
+ − 297
+ − 298 (defun custom-theme-reset-internal-face (face to-theme)
+ − 299 (let ((spec (custom-theme-face-value face to-theme))
+ − 300 was-in-theme)
+ − 301 (setq was-in-theme spec)
+ − 302 (setq spec (or spec (get face 'standard-value)))
+ − 303 (when spec
+ − 304 (put face 'save-face was-in-theme)
+ − 305 (when (or (get face 'force-face) (find-face face))
+ − 306 (unless (find-face face)
+ − 307 (make-empty-face face))
+ − 308 (face-spec-set face spec)))
+ − 309 spec))
+ − 310
+ − 311 ;;;###autoload
+ − 312 (defun custom-theme-reset-faces (theme &rest args)
+ − 313 (custom-check-theme theme)
+ − 314 "Reset the value of the face to values previously defined.
442
+ − 315 Associate this setting with THEME.
428
+ − 316
+ − 317 ARGS is a list of lists of the form
+ − 318
+ − 319 (face to-theme)
+ − 320
+ − 321 This means reset face to its value in to-theme."
+ − 322 (mapc #'(lambda (arg)
+ − 323 (apply #'custom-theme-reset-internal-face arg)
+ − 324 (custom-push-theme (car arg) 'theme-face theme 'reset (cadr arg)))
+ − 325 args))
+ − 326
+ − 327 ;;;###autoload
+ − 328 (defun custom-reset-faces (&rest args)
+ − 329 "Reset the value of the face to values previously defined.
442
+ − 330 Associate this setting with the 'user' theme.
428
+ − 331
444
+ − 332 ARGS is defined as for `custom-theme-reset-faces'."
428
+ − 333 (apply #'custom-theme-reset-faces 'user args))
+ − 334
+ − 335
+ − 336 ;;; The End.
+ − 337
+ − 338 (provide 'cus-face)
+ − 339
+ − 340 ;; cus-face.el ends here
