| 1 | ;;; cus-face.el --- customization support for faces |
| 2 | ;; |
| 3 | ;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, |
| 4 | ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
| 5 | ;; |
| 6 | ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> |
| 7 | ;; Keywords: help, faces |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 3, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 23 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 24 | ;; Boston, MA 02110-1301, USA. |
| 25 | |
| 26 | ;;; Commentary: |
| 27 | ;; |
| 28 | ;; See `custom.el'. |
| 29 | |
| 30 | ;;; Code: |
| 31 | |
| 32 | (defalias 'custom-facep 'facep) |
| 33 | |
| 34 | ;;; Declaring a face. |
| 35 | |
| 36 | ;;;###autoload |
| 37 | (defun custom-declare-face (face spec doc &rest args) |
| 38 | "Like `defface', but FACE is evaluated as a normal argument." |
| 39 | (unless (get face 'face-defface-spec) |
| 40 | (when (fboundp 'facep) |
| 41 | (unless (facep face) |
| 42 | ;; If the user has already created the face, respect that. |
| 43 | (let ((value (or (get face 'saved-face) spec)) |
| 44 | (have-window-system (memq initial-window-system '(x w32)))) |
| 45 | ;; Create global face. |
| 46 | (make-empty-face face) |
| 47 | ;; Create frame-local faces |
| 48 | (dolist (frame (frame-list)) |
| 49 | (face-spec-set-2 face frame value) |
| 50 | (when (memq (window-system frame) '(x w32 mac)) |
| 51 | (setq have-window-system t))) |
| 52 | ;; When making a face after frames already exist |
| 53 | (if have-window-system |
| 54 | (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 | (push (cons 'defface face) current-load-list) |
| 58 | (when (and doc (null (face-documentation face))) |
| 59 | (set-face-documentation face (purecopy doc))) |
| 60 | (custom-handle-all-keywords face args 'custom-face) |
| 61 | (run-hooks 'custom-define-hook)) |
| 62 | face) |
| 63 | |
| 64 | ;;; Face attributes. |
| 65 | |
| 66 | ;;;###autoload |
| 67 | (defconst custom-face-attributes |
| 68 | '((:family |
| 69 | (string :tag "Font Family" |
| 70 | :help-echo "Font family or fontset alias name.")) |
| 71 | |
| 72 | (:width |
| 73 | (choice :tag "Width" |
| 74 | :help-echo "Font width." |
| 75 | :value normal ; default |
| 76 | (const :tag "compressed" condensed) |
| 77 | (const :tag "condensed" condensed) |
| 78 | (const :tag "demiexpanded" semi-expanded) |
| 79 | (const :tag "expanded" expanded) |
| 80 | (const :tag "extracondensed" extra-condensed) |
| 81 | (const :tag "extraexpanded" extra-expanded) |
| 82 | (const :tag "medium" normal) |
| 83 | (const :tag "narrow" condensed) |
| 84 | (const :tag "normal" normal) |
| 85 | (const :tag "regular" normal) |
| 86 | (const :tag "semicondensed" semi-condensed) |
| 87 | (const :tag "semiexpanded" semi-expanded) |
| 88 | (const :tag "ultracondensed" ultra-condensed) |
| 89 | (const :tag "ultraexpanded" ultra-expanded) |
| 90 | (const :tag "wide" extra-expanded))) |
| 91 | |
| 92 | (:height |
| 93 | (choice :tag "Height" |
| 94 | :help-echo "Face's font height." |
| 95 | :value 1.0 ; default |
| 96 | (integer :tag "Height in 1/10 pt") |
| 97 | (number :tag "Scale" 1.0))) |
| 98 | |
| 99 | (:weight |
| 100 | (choice :tag "Weight" |
| 101 | :help-echo "Font weight." |
| 102 | :value normal ; default |
| 103 | (const :tag "black" ultra-bold) |
| 104 | (const :tag "bold" bold) |
| 105 | (const :tag "book" semi-light) |
| 106 | (const :tag "demibold" semi-bold) |
| 107 | (const :tag "extralight" extra-light) |
| 108 | (const :tag "extrabold" extra-bold) |
| 109 | (const :tag "heavy" extra-bold) |
| 110 | (const :tag "light" light) |
| 111 | (const :tag "medium" normal) |
| 112 | (const :tag "normal" normal) |
| 113 | (const :tag "regular" normal) |
| 114 | (const :tag "semibold" semi-bold) |
| 115 | (const :tag "semilight" semi-light) |
| 116 | (const :tag "ultralight" ultra-light) |
| 117 | (const :tag "ultrabold" ultra-bold))) |
| 118 | |
| 119 | (:slant |
| 120 | (choice :tag "Slant" |
| 121 | :help-echo "Font slant." |
| 122 | :value normal ; default |
| 123 | (const :tag "italic" italic) |
| 124 | (const :tag "oblique" oblique) |
| 125 | (const :tag "normal" normal))) |
| 126 | |
| 127 | (:underline |
| 128 | (choice :tag "Underline" |
| 129 | :help-echo "Control text underlining." |
| 130 | (const :tag "Off" nil) |
| 131 | (const :tag "On" t) |
| 132 | (color :tag "Colored"))) |
| 133 | |
| 134 | (:overline |
| 135 | (choice :tag "Overline" |
| 136 | :help-echo "Control text overlining." |
| 137 | (const :tag "Off" nil) |
| 138 | (const :tag "On" t) |
| 139 | (color :tag "Colored"))) |
| 140 | |
| 141 | (:strike-through |
| 142 | (choice :tag "Strike-through" |
| 143 | :help-echo "Control text strike-through." |
| 144 | (const :tag "Off" nil) |
| 145 | (const :tag "On" t) |
| 146 | (color :tag "Colored"))) |
| 147 | |
| 148 | (:box |
| 149 | ;; Fixme: this can probably be done better. |
| 150 | (choice :tag "Box around text" |
| 151 | :help-echo "Control box around text." |
| 152 | (const :tag "Off" nil) |
| 153 | (list :tag "Box" |
| 154 | :value (:line-width 2 :color "grey75" :style released-button) |
| 155 | (const :format "" :value :line-width) |
| 156 | (integer :tag "Width") |
| 157 | (const :format "" :value :color) |
| 158 | (choice :tag "Color" (const :tag "*" nil) color) |
| 159 | (const :format "" :value :style) |
| 160 | (choice :tag "Style" |
| 161 | (const :tag "Raised" released-button) |
| 162 | (const :tag "Sunken" pressed-button) |
| 163 | (const :tag "None" nil)))) |
| 164 | ;; filter to make value suitable for customize |
| 165 | (lambda (real-value) |
| 166 | (and real-value |
| 167 | (let ((lwidth |
| 168 | (or (and (consp real-value) |
| 169 | (plist-get real-value :line-width)) |
| 170 | (and (integerp real-value) real-value) |
| 171 | 1)) |
| 172 | (color |
| 173 | (or (and (consp real-value) (plist-get real-value :color)) |
| 174 | (and (stringp real-value) real-value) |
| 175 | nil)) |
| 176 | (style |
| 177 | (and (consp real-value) (plist-get real-value :style)))) |
| 178 | (list :line-width lwidth :color color :style style)))) |
| 179 | ;; filter to make customized-value suitable for storing |
| 180 | (lambda (cus-value) |
| 181 | (and cus-value |
| 182 | (let ((lwidth (plist-get cus-value :line-width)) |
| 183 | (color (plist-get cus-value :color)) |
| 184 | (style (plist-get cus-value :style))) |
| 185 | (cond ((and (null color) (null style)) |
| 186 | lwidth) |
| 187 | ((and (null lwidth) (null style)) |
| 188 | ;; actually can't happen, because LWIDTH is always an int |
| 189 | color) |
| 190 | (t |
| 191 | ;; Keep as a plist, but remove null entries |
| 192 | (nconc (and lwidth `(:line-width ,lwidth)) |
| 193 | (and color `(:color ,color)) |
| 194 | (and style `(:style ,style))))))))) |
| 195 | |
| 196 | (:inverse-video |
| 197 | (choice :tag "Inverse-video" |
| 198 | :help-echo "Control whether text should be in inverse-video." |
| 199 | (const :tag "Off" nil) |
| 200 | (const :tag "On" t))) |
| 201 | |
| 202 | (:foreground |
| 203 | (color :tag "Foreground" |
| 204 | :help-echo "Set foreground color (name or #RRGGBB hex spec).")) |
| 205 | |
| 206 | (:background |
| 207 | (color :tag "Background" |
| 208 | :help-echo "Set background color (name or #RRGGBB hex spec).")) |
| 209 | |
| 210 | (:stipple |
| 211 | (choice :tag "Stipple" |
| 212 | :help-echo "Background bit-mask" |
| 213 | (const :tag "None" nil) |
| 214 | (file :tag "File" |
| 215 | :help-echo "Name of bitmap file." |
| 216 | :must-match t))) |
| 217 | |
| 218 | (:inherit |
| 219 | (repeat :tag "Inherit" |
| 220 | :help-echo "List of faces to inherit attributes from." |
| 221 | (face :Tag "Face" default)) |
| 222 | ;; filter to make value suitable for customize |
| 223 | (lambda (real-value) |
| 224 | (cond ((or (null real-value) (eq real-value 'unspecified)) |
| 225 | nil) |
| 226 | ((symbolp real-value) |
| 227 | (list real-value)) |
| 228 | (t |
| 229 | real-value))) |
| 230 | ;; filter to make customized-value suitable for storing |
| 231 | (lambda (cus-value) |
| 232 | (if (and (consp cus-value) (null (cdr cus-value))) |
| 233 | (car cus-value) |
| 234 | cus-value)))) |
| 235 | |
| 236 | "Alist of face attributes. |
| 237 | |
| 238 | The elements are of the form (KEY TYPE PRE-FILTER POST-FILTER), |
| 239 | where KEY is the name of the attribute, TYPE is a widget type for |
| 240 | editing the attribute, PRE-FILTER is a function to make the attribute's |
| 241 | value suitable for the customization widget, and POST-FILTER is a |
| 242 | function to make the customized value suitable for storing. PRE-FILTER |
| 243 | and POST-FILTER are optional. |
| 244 | |
| 245 | The PRE-FILTER should take a single argument, the attribute value as |
| 246 | stored, and should return a value for customization (using the |
| 247 | customization type TYPE). |
| 248 | |
| 249 | The POST-FILTER should also take a single argument, the value after |
| 250 | being customized, and should return a value suitable for setting the |
| 251 | given face attribute.") |
| 252 | |
| 253 | (defun custom-face-attributes-get (face frame) |
| 254 | "For FACE on FRAME, return an alternating list describing its attributes. |
| 255 | The list has the form (KEYWORD VALUE KEYWORD VALUE...). |
| 256 | Each keyword should be listed in `custom-face-attributes'. |
| 257 | |
| 258 | If FRAME is nil, use the global defaults for FACE." |
| 259 | (let ((attrs custom-face-attributes) |
| 260 | plist) |
| 261 | (while attrs |
| 262 | (let* ((attribute (car (car attrs))) |
| 263 | (value (face-attribute face attribute frame))) |
| 264 | (setq attrs (cdr attrs)) |
| 265 | (unless (or (eq value 'unspecified) |
| 266 | (and (null value) (memq attribute '(:inherit)))) |
| 267 | (setq plist (cons attribute (cons value plist)))))) |
| 268 | plist)) |
| 269 | |
| 270 | ;;; Initializing. |
| 271 | |
| 272 | ;;;###autoload |
| 273 | (defun custom-set-faces (&rest args) |
| 274 | "Initialize faces according to user preferences. |
| 275 | This associates the settings with the `user' theme. |
| 276 | The arguments should be a list where each entry has the form: |
| 277 | |
| 278 | (FACE SPEC [NOW [COMMENT]]) |
| 279 | |
| 280 | SPEC is stored as the saved value for FACE, as well as the value for the |
| 281 | `user' theme. The `user' theme is one of the default themes known to Emacs. |
| 282 | See `custom-known-themes' for more information on the known themes. |
| 283 | See `custom-theme-set-faces' for more information on the interplay |
| 284 | between themes and faces. |
| 285 | See `defface' for the format of SPEC. |
| 286 | |
| 287 | If NOW is present and non-nil, FACE is created now, according to SPEC. |
| 288 | COMMENT is a string comment about FACE." |
| 289 | (apply 'custom-theme-set-faces 'user args)) |
| 290 | |
| 291 | (defun custom-theme-set-faces (theme &rest args) |
| 292 | "Initialize faces for theme THEME. |
| 293 | The arguments should be a list where each entry has the form: |
| 294 | |
| 295 | (FACE SPEC [NOW [COMMENT]]) |
| 296 | |
| 297 | SPEC is stored as the saved value for FACE, as well as the value for the |
| 298 | `user' theme. The `user' theme is one of the default themes known to Emacs. |
| 299 | See `custom-known-themes' for more information on the known themes. |
| 300 | See `custom-theme-set-faces' for more information on the interplay |
| 301 | between themes and faces. |
| 302 | See `defface' for the format of SPEC. |
| 303 | |
| 304 | If NOW is present and non-nil, FACE is created now, according to SPEC. |
| 305 | COMMENT is a string comment about FACE. |
| 306 | |
| 307 | Several properties of THEME and FACE are used in the process: |
| 308 | |
| 309 | If THEME property `theme-immediate' is non-nil, this is equivalent of |
| 310 | providing the NOW argument to all faces in the argument list: FACE is |
| 311 | created now. The only difference is FACE property `force-face': if NOW |
| 312 | is non-nil, FACE property `force-face' is set to the symbol `rogue', else |
| 313 | if THEME property `theme-immediate' is non-nil, FACE property `force-face' |
| 314 | is set to the symbol `immediate'. |
| 315 | |
| 316 | SPEC itself is saved in FACE property `saved-face' and it is stored in |
| 317 | FACE's list property `theme-face' \(using `custom-push-theme')." |
| 318 | (custom-check-theme theme) |
| 319 | (let ((immediate (get theme 'theme-immediate))) |
| 320 | (while args |
| 321 | (let ((entry (car args))) |
| 322 | (if (listp entry) |
| 323 | (let ((face (nth 0 entry)) |
| 324 | (spec (nth 1 entry)) |
| 325 | (now (nth 2 entry)) |
| 326 | (comment (nth 3 entry)) |
| 327 | oldspec) |
| 328 | ;; If FACE is actually an alias, customize the face it |
| 329 | ;; is aliased to. |
| 330 | (if (get face 'face-alias) |
| 331 | (setq face (get face 'face-alias))) |
| 332 | |
| 333 | (setq oldspec (get face 'theme-face)) |
| 334 | (when (not (and oldspec (eq 'user (caar oldspec)))) |
| 335 | (put face 'saved-face spec) |
| 336 | (put face 'saved-face-comment comment)) |
| 337 | |
| 338 | (custom-push-theme 'theme-face face theme 'set spec) |
| 339 | (when (or now immediate) |
| 340 | (put face 'force-face (if now 'rogue 'immediate))) |
| 341 | (when (or now immediate (facep face)) |
| 342 | (unless (facep face) |
| 343 | (make-empty-face face)) |
| 344 | (put face 'face-comment comment) |
| 345 | (put face 'face-override-spec nil) |
| 346 | (face-spec-set face spec t)) |
| 347 | (setq args (cdr args))) |
| 348 | ;; Old format, a plist of FACE SPEC pairs. |
| 349 | (let ((face (nth 0 args)) |
| 350 | (spec (nth 1 args))) |
| 351 | (if (get face 'face-alias) |
| 352 | (setq face (get face 'face-alias))) |
| 353 | (put face 'saved-face spec) |
| 354 | (custom-push-theme 'theme-face face theme 'set spec)) |
| 355 | (setq args (cdr (cdr args)))))))) |
| 356 | |
| 357 | ;; XEmacs compability function. In XEmacs, when you reset a Custom |
| 358 | ;; Theme, you have to specify the theme to reset it to. We just apply |
| 359 | ;; the next theme. |
| 360 | ;;;###autoload |
| 361 | (defun custom-theme-reset-faces (theme &rest args) |
| 362 | "Reset the specs in THEME of some faces to their specs in other themes. |
| 363 | Each of the arguments ARGS has this form: |
| 364 | |
| 365 | (FACE IGNORED) |
| 366 | |
| 367 | This means reset FACE. The argument IGNORED is ignored." |
| 368 | (custom-check-theme theme) |
| 369 | (dolist (arg args) |
| 370 | (custom-push-theme 'theme-face (car arg) theme 'reset))) |
| 371 | |
| 372 | ;;;###autoload |
| 373 | (defun custom-reset-faces (&rest args) |
| 374 | "Reset the specs of some faces to their specs in specified themes. |
| 375 | This creates settings in the `user' theme. |
| 376 | |
| 377 | Each of the arguments ARGS has this form: |
| 378 | |
| 379 | (FACE FROM-THEME) |
| 380 | |
| 381 | This means reset FACE to its value in FROM-THEME." |
| 382 | (apply 'custom-theme-reset-faces 'user args)) |
| 383 | |
| 384 | ;;; The End. |
| 385 | |
| 386 | (provide 'cus-face) |
| 387 | |
| 388 | ;;; arch-tag: 9a5c4b63-0d27-4c92-a5af-f2c7ed764c2b |
| 389 | ;;; cus-face.el ends here |