Mercurial > hg > xemacs-beta
comparison lisp/prim/faces.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | ac2d302a0011 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; faces.el --- Lisp interface to the C "face" structure | |
| 2 | |
| 3 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois | |
| 5 ;; Copyright (C) 1995, 1996 Ben Wing | |
| 6 | |
| 7 ;; Author: Ben Wing <wing@666.com> | |
| 8 ;; Keywords: faces internal | |
| 9 ;; | |
| 10 ;; face implementation #1 (used Lisp vectors and parallel C vectors; | |
| 11 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@netscape.com> | |
| 12 ;; pre Lucid-Emacs 19.0. | |
| 13 ;; | |
| 14 ;; face implementation #2 (used one face object per frame per face) | |
| 15 ;; authored by Jamie Zawinkski for 19.9. | |
| 16 ;; | |
| 17 ;; face implementation #3 (use one face object per face) originally | |
| 18 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, | |
| 19 ;; rewritten by Ben Wing with the advent of specifiers. | |
| 20 | |
| 21 ;; This file is part of XEmacs. | |
| 22 | |
| 23 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 24 ;; under the terms of the GNU General Public License as published by | |
| 25 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 26 ;; any later version. | |
| 27 | |
| 28 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 29 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 30 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 31 ;; General Public License for more details. | |
| 32 | |
| 33 ;; You should have received a copy of the GNU General Public License | |
| 34 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 35 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 36 | |
| 37 ;;; Synched up with: Not synched with FSF. Almost completely divergent. | |
| 38 ;;; Some stuff in FSF's faces.el is in our x-faces.el. | |
| 39 | |
| 40 (defun read-face-name (prompt) | |
| 41 (let (face) | |
| 42 (while (= (length face) 0) ; nil or "" | |
| 43 (setq face (completing-read prompt | |
| 44 (mapcar '(lambda (x) (list (symbol-name x))) | |
| 45 (face-list)) | |
| 46 nil t))) | |
| 47 (intern face))) | |
| 48 | |
| 49 (defun face-interactive (what &optional bool) | |
| 50 (let* ((fn (intern (concat "face-" what "-instance"))) | |
| 51 (face (read-face-name (format "Set %s of face: " what))) | |
| 52 (default (if (fboundp fn) | |
| 53 ;; #### we should distinguish here between | |
| 54 ;; explicitly setting the value to be the | |
| 55 ;; same as the default face's value, and | |
| 56 ;; not setting a value at all. | |
| 57 (funcall fn face))) | |
| 58 (value (if bool | |
| 59 (y-or-n-p (format "Should face %s be %s? " | |
| 60 (symbol-name face) bool)) | |
| 61 (read-string (format "Set %s of face %s to: " | |
| 62 what (symbol-name face)) | |
| 63 (cond ((font-instance-p default) | |
| 64 (font-instance-name default)) | |
| 65 ((color-instance-p default) | |
| 66 (color-instance-name default)) | |
| 67 ((image-instance-p default) | |
| 68 (image-instance-file-name default)) | |
| 69 (t default)))))) | |
| 70 (list face (if (equal value "") nil value)))) | |
| 71 | |
| 72 (defconst built-in-face-specifiers | |
| 73 (built-in-face-specifiers) | |
| 74 "A list of the built-in face properties that are specifiers.") | |
| 75 | |
| 76 (defun face-property (face property &optional locale tag-set exact-p) | |
| 77 "Return FACE's value of the given PROPERTY. | |
| 78 | |
| 79 If LOCALE is omitted, the FACE's actual value for PROPERTY will be | |
| 80 returned. For built-in properties, this will be a specifier object | |
| 81 of a type appropriate to the property (e.g. a font or color | |
| 82 specifier). For other properties, this could be anything. | |
| 83 | |
| 84 If LOCALE is supplied, then instead of returning the actual value, | |
| 85 the specification(s) for the given locale or locale type will | |
| 86 be returned. This will only work if the actual value of | |
| 87 PROPERTY is a specifier (this will always be the case for built-in | |
| 88 properties, but not or not may apply to user-defined properties). | |
| 89 If the actual value of PROPERTY is not a specifier, this value | |
| 90 will simply be returned regardless of LOCALE. | |
| 91 | |
| 92 The return value will be a list of instantiators (e.g. strings | |
| 93 specifying a font or color name), or a list of specifications, each | |
| 94 of which is a cons of a locale and a list of instantiators. | |
| 95 Specifically, if LOCALE is a particular locale (a buffer, window, | |
| 96 frame, device, or 'global), a list of instantiators for that locale | |
| 97 will be returned. Otherwise, if LOCALE is a locale type (one of | |
| 98 the symbols 'buffer, 'window, 'frame, or 'device), the specifications | |
| 99 for all locales of that type will be returned. Finally, if LOCALE is | |
| 100 'all, the specifications for all locales of all types will be returned. | |
| 101 | |
| 102 The specifications in a specifier determine what the value of | |
| 103 PROPERTY will be in a particular \"domain\" or set of circumstances, | |
| 104 which is typically a particular Emacs window along with the buffer | |
| 105 it contains and the frame and device it lies within. The value | |
| 106 is derived from the instantiator associated with the most specific | |
| 107 locale (in the order buffer, window, frame, device, and 'global) | |
| 108 that matches the domain in question. In other words, given a domain | |
| 109 (i.e. an Emacs window, usually), the specifier for PROPERTY will first | |
| 110 be searched for a specification whose locale is the buffer contained | |
| 111 within that window; then for a specification whose locale is the window | |
| 112 itself; then for a specification whose locale is the frame that the | |
| 113 window is contained within; etc. The first instantiator that is | |
| 114 valid for the domain (usually this means that the instantiator is | |
| 115 recognized by the device [i.e. the X server or TTY device] that the | |
| 116 domain is on. The function `face-property-instance' actually does | |
| 117 all this, and is used to determine how to display the face. | |
| 118 | |
| 119 See `set-face-property' for the built-in property-names." | |
| 120 | |
| 121 (or (facep face) (setq face (get-face face))) | |
| 122 (let ((value (get face property))) | |
| 123 (if (and locale | |
| 124 (or (memq property built-in-face-specifiers) | |
| 125 (specifierp value))) | |
| 126 (setq value (specifier-specs value locale tag-set exact-p))) | |
| 127 value)) | |
| 128 | |
| 129 (defun convert-face-property-into-specifier (face property) | |
| 130 "Convert PROPERTY on FACE into a specifier, if it's not already." | |
| 131 (setq face (get-face face)) | |
| 132 (let ((specifier (get face property))) | |
| 133 ;; if a user-property does not have a specifier but a | |
| 134 ;; locale was specified, put a specifier there. | |
| 135 ;; If there was already a value there, convert it to a | |
| 136 ;; specifier with the value as its 'global instantiator. | |
| 137 (if (not (specifierp specifier)) | |
| 138 (let ((new-specifier (make-specifier 'generic))) | |
| 139 (if (or (not (null specifier)) | |
| 140 ;; make sure the nil returned from `get' wasn't | |
| 141 ;; actually the value of the property | |
| 142 (null (get face property t))) | |
| 143 (add-spec-to-specifier new-specifier specifier)) | |
| 144 (setq specifier new-specifier) | |
| 145 (put face property specifier))))) | |
| 146 | |
| 147 (defun face-property-instance (face property | |
| 148 &optional domain default no-fallback) | |
| 149 "Return the instance of FACE's PROPERTY in the specified DOMAIN. | |
| 150 | |
| 151 Under most circumstances, DOMAIN will be a particular window, | |
| 152 and the returned instance describes how the specified property | |
| 153 actually is displayed for that window and the particular buffer | |
| 154 in it. Note that this may not be the same as how the property | |
| 155 appears when the buffer is displayed in a different window or | |
| 156 frame, or how the property appears in the same window if you | |
| 157 switch to another buffer in that window; and in those cases, | |
| 158 the returned instance would be different. | |
| 159 | |
| 160 The returned instance will typically be a color-instance, | |
| 161 font-instance, or pixmap-instance object, and you can query | |
| 162 it using the appropriate object-specific functions. For example, | |
| 163 you could use `color-instance-rgb-components' to find out the | |
| 164 RGB (red, green, and blue) components of how the 'background | |
| 165 property of the 'highlight face is displayed in a particular | |
| 166 window. The results might be different from the results | |
| 167 you would get for another window (perhaps the user | |
| 168 specified a different color for the frame that window is on; | |
| 169 or perhaps the same color was specified but the window is | |
| 170 on a different X server, and that X server has different RGB | |
| 171 values for the color from this one). | |
| 172 | |
| 173 DOMAIN defaults to the selected window if omitted. | |
| 174 | |
| 175 DOMAIN can be a frame or device, instead of a window. The value | |
| 176 returned for a such a domain is used in special circumstances | |
| 177 when a more specific domain does not apply; for example, a frame | |
| 178 value might be used for coloring a toolbar, which is conceptually | |
| 179 attached to a frame rather than a particular window. The value | |
| 180 is also useful in determining what the value would be for a | |
| 181 particular window within the frame or device, if it is not | |
| 182 overridden by a more specific specification. | |
| 183 | |
| 184 If PROPERTY does not name a built-in property, its value will | |
| 185 simply be returned unless it is a specifier object, in which case | |
| 186 it will be instanced using `specifier-instance'. | |
| 187 | |
| 188 Optional arguments DEFAULT and NO-FALLBACK are the same as in | |
| 189 `specifier-instance'." | |
| 190 | |
| 191 (or (facep face) (setq face (get-face face))) | |
| 192 (let ((value (get face property))) | |
| 193 (if (specifierp value) | |
| 194 (setq value (specifier-instance value domain default no-fallback))) | |
| 195 value)) | |
| 196 | |
| 197 (defun face-property-matching-instance (face property matchspec | |
| 198 &optional domain default | |
| 199 no-fallback) | |
| 200 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. | |
| 201 Currently the only useful value for MATCHSPEC is a charset, when used | |
| 202 in conjunction with the face's font; this allows you to retrieve a | |
| 203 font that can be used to display a particular charset, rather than just | |
| 204 any font. | |
| 205 | |
| 206 Other than MATCHSPEC, this function is identical to `face-property-instance'. | |
| 207 See also `specifier-matching-instance' for a fuller description of the | |
| 208 matching process." | |
| 209 | |
| 210 (or (facep face) (setq face (get-face face))) | |
| 211 (let ((value (get face property))) | |
| 212 (if (specifierp value) | |
| 213 (setq value (specifier-matching-instance value matchspec domain | |
| 214 default no-fallback))) | |
| 215 value)) | |
| 216 | |
| 217 (defun set-face-property (face property value &optional locale tag-set | |
| 218 how-to-add) | |
| 219 "Change a property of a FACE. | |
| 220 | |
| 221 NOTE: If you want to remove a property from a face, use `remove-face-property' | |
| 222 rather than attempting to set a value of nil for the property. | |
| 223 | |
| 224 For built-in properties, the actual value of the property is a | |
| 225 specifier and you cannot change this; but you can change the | |
| 226 specifications within the specifier, and that is what this function | |
| 227 will do. For user-defined properties, you can use this function | |
| 228 to either change the actual value of the property or, if this value | |
| 229 is a specifier, change the specifications within it. | |
| 230 | |
| 231 If PROPERTY is a built-in property, the specifications to be added to | |
| 232 this property can be supplied in many different ways: | |
| 233 | |
| 234 -- If VALUE is a simple instantiator (e.g. a string naming a font or | |
| 235 color) or a list of instantiators, then the instantiator(s) will | |
| 236 be added as a specification of the property for the given LOCALE | |
| 237 (which defaults to 'global if omitted). | |
| 238 -- If VALUE is a list of specifications (each of which is a cons of | |
| 239 a locale and a list of instantiators), then LOCALE must be nil | |
| 240 (it does not make sense to explicitly specify a locale in this | |
| 241 case), and specifications will be added as given. | |
| 242 -- If VALUE is a specifier (as would be returned by `face-property' | |
| 243 if no LOCALE argument is given), then some or all of the | |
| 244 specifications in the specifier will be added to the property. | |
| 245 In this case, the function is really equivalent to | |
| 246 `copy-specifier' and LOCALE has the same semantics (if it is | |
| 247 a particular locale, the specification for the locale will be | |
| 248 copied; if a locale type, specifications for all locales of | |
| 249 that type will be copied; if nil or 'all, then all | |
| 250 specifications will be copied). | |
| 251 | |
| 252 HOW-TO-ADD should be either nil or one of the symbols 'prepend, | |
| 253 'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale, | |
| 254 'remove-locale-type, or 'remove-all. See `copy-specifier' and | |
| 255 `add-spec-to-specifier' for a description of what each of | |
| 256 these means. Most of the time, you do not need to worry about | |
| 257 this argument; the default behavior usually is fine. | |
| 258 | |
| 259 In general, it is OK to pass an instance object (e.g. as returned | |
| 260 by `face-property-instance') as an instantiator in place of | |
| 261 an actual instantiator. In such a case, the instantiator used | |
| 262 to create that instance object will be used (for example, if | |
| 263 you set a font-instance object as the value of the 'font | |
| 264 property, then the font name used to create that object will | |
| 265 be used instead). If some cases, however, doing this | |
| 266 conversion does not make sense, and this will be noted in | |
| 267 the documentation for particular types of instance objects. | |
| 268 | |
| 269 If PROPERTY is not a built-in property, then this function will | |
| 270 simply set its value if LOCALE is nil. However, if LOCALE is | |
| 271 given, then this function will attempt to add VALUE as the | |
| 272 instantiator for the given LOCALE, using `add-spec-to-specifier'. | |
| 273 If the value of the property is not a specifier, it will | |
| 274 automatically be converted into a 'generic specifier. | |
| 275 | |
| 276 | |
| 277 The following symbols have predefined meanings: | |
| 278 | |
| 279 foreground The foreground color of the face. | |
| 280 For valid instantiators, see `color-specifier-p'. | |
| 281 | |
| 282 background The background color of the face. | |
| 283 For valid instantiators, see `color-specifier-p'. | |
| 284 | |
| 285 font The font used to display text covered by this face. | |
| 286 For valid instantiators, see `font-specifier-p'. | |
| 287 | |
| 288 display-table The display table of the face. | |
| 289 This should be a vector of 256 elements. | |
| 290 | |
| 291 background-pixmap The pixmap displayed in the background of the face. | |
| 292 Only used by faces on X devices. | |
| 293 For valid instantiators, see `image-specifier-p'. | |
| 294 | |
| 295 underline Underline all text covered by this face. | |
| 296 For valid instantiators, see `face-boolean-specifier-p'. | |
| 297 | |
| 298 strikethru Draw a line through all text covered by this face. | |
| 299 For valid instantiators, see `face-boolean-specifier-p'. | |
| 300 | |
| 301 highlight Highlight all text covered by this face. | |
| 302 Only used by faces on TTY devices. | |
| 303 For valid instantiators, see `face-boolean-specifier-p'. | |
| 304 | |
| 305 dim Dim all text covered by this face. | |
| 306 Only used by faces on TTY devices. | |
| 307 For valid instantiators, see `face-boolean-specifier-p'. | |
| 308 | |
| 309 blinking Blink all text covered by this face. | |
| 310 Only used by faces on TTY devices. | |
| 311 For valid instantiators, see `face-boolean-specifier-p'. | |
| 312 | |
| 313 reverse Reverse the foreground and background colors. | |
| 314 Only used by faces on TTY devices. | |
| 315 For valid instantiators, see `face-boolean-specifier-p'. | |
| 316 | |
| 317 doc-string Description of what the face's normal use is. | |
| 318 NOTE: This is not a specifier, unlike all | |
| 319 the other built-in properties, and cannot | |
| 320 contain locale-specific values." | |
| 321 | |
| 322 (or (facep face) (setq face (get-face face))) | |
| 323 (if (memq property built-in-face-specifiers) | |
| 324 (set-specifier (get face property) value locale tag-set how-to-add) | |
| 325 | |
| 326 ;; This section adds user defined properties. | |
| 327 (if (not locale) | |
| 328 (put face property value) | |
| 329 (convert-face-property-into-specifier face property) | |
| 330 (add-spec-to-specifier (get face property) value locale tag-set | |
| 331 how-to-add))) | |
| 332 value) | |
| 333 | |
| 334 (defun remove-face-property (face property &optional locale tag-set exact-p) | |
| 335 "Remove a property from a face. | |
| 336 For built-in properties, this is analogous to `remove-specifier'. | |
| 337 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P | |
| 338 arguments." | |
| 339 (or locale (setq locale 'all)) | |
| 340 (if (memq property built-in-face-specifiers) | |
| 341 (remove-specifier (face-property face property) locale tag-set exact-p) | |
| 342 (if (eq locale 'all) | |
| 343 (remprop (get-face face) property) | |
| 344 (convert-face-property-into-specifier face property) | |
| 345 (remove-specifier (face-property face property) locale tag-set | |
| 346 exact-p)))) | |
| 347 | |
| 348 (defun reset-face (face) | |
| 349 "Clear all existing built-in specifications from FACE. | |
| 350 This makes FACE inherit all its display properties from 'default. | |
| 351 WARNING: Be absolutely sure you want to do this!!! It is a dangerous | |
| 352 operation and is not undoable." | |
| 353 (mapcar #'(lambda (x) | |
| 354 (remove-specifier (face-property face x))) | |
| 355 built-in-face-specifiers) | |
| 356 nil) | |
| 357 | |
| 358 (defun set-face-parent (face parent &optional locale tag-set how-to-add) | |
| 359 "Set the parent of FACE to PARENT, for all properties. | |
| 360 This makes all properties of FACE inherit from PARENT." | |
| 361 (setq parent (get-face parent)) | |
| 362 (mapcar #'(lambda (x) | |
| 363 (set-face-property face x (vector parent) locale tag-set | |
| 364 how-to-add)) | |
| 365 (delq 'display-table | |
| 366 (delq 'background-pixmap | |
| 367 (copy-sequence built-in-face-specifiers)))) | |
| 368 (set-face-background-pixmap face (vector 'inherit ':face parent) | |
| 369 locale tag-set how-to-add) | |
| 370 nil) | |
| 371 | |
| 372 (defun face-doc-string (face) | |
| 373 "Return the documentation string for FACE." | |
| 374 (face-property face 'doc-string)) | |
| 375 | |
| 376 (defun set-face-doc-string (face doc-string) | |
| 377 "Change the documentation string of FACE to DOC-STRING." | |
| 378 (interactive (face-interactive "doc-string")) | |
| 379 (set-face-property face 'doc-string doc-string)) | |
| 380 | |
| 381 (defun face-font-name (face &optional domain charset) | |
| 382 "Return the font name of the given face, or nil if it is unspecified. | |
| 383 DOMAIN is as in `face-font-instance'." | |
| 384 (let ((f (face-font-instance face domain charset))) | |
| 385 (and f (font-instance-name f)))) | |
| 386 | |
| 387 (defun face-font (face &optional locale tag-set exact-p) | |
| 388 "Return the font of the given face, or nil if it is unspecified. | |
| 389 | |
| 390 FACE may be either a face object or a symbol representing a face. | |
| 391 | |
| 392 LOCALE may be a locale (the instantiators for that particular locale | |
| 393 will be returned), a locale type (the specifications for all locales | |
| 394 of that type will be returned), 'all (all specifications will be | |
| 395 returned), or nil (the actual specifier object will be returned). | |
| 396 | |
| 397 See `face-property' for more information." | |
| 398 (face-property face 'font locale tag-set exact-p)) | |
| 399 | |
| 400 (defun face-font-instance (face &optional domain charset) | |
| 401 "Return the instance of the given face's font in the given domain. | |
| 402 | |
| 403 FACE may be either a face object or a symbol representing a face. | |
| 404 | |
| 405 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 406 and an instance object describing how the font appears in that | |
| 407 particular window and buffer will be returned. | |
| 408 | |
| 409 See `face-property-instance' for more information." | |
| 410 (if charset | |
| 411 (face-property-matching-instance face 'font charset domain) | |
| 412 (face-property-instance face 'font domain))) | |
| 413 | |
| 414 (defun set-face-font (face font &optional locale tag-set how-to-add) | |
| 415 "Change the font of the given face. | |
| 416 | |
| 417 FACE may be either a face object or a symbol representing a face. | |
| 418 | |
| 419 FONT should be an instantiator (see `font-specifier-p'), a list of | |
| 420 instantiators, an alist of specifications (each mapping a | |
| 421 locale to an instantiator list), or a font specifier object. | |
| 422 | |
| 423 If FONT is an alist, LOCALE must be omitted. If FONT is a | |
| 424 specifier object, LOCALE can be a locale, a locale type, 'all, | |
| 425 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE | |
| 426 specifies the locale under which the specified instantiator(s) | |
| 427 will be added, and defaults to 'global. | |
| 428 | |
| 429 See `set-face-property' for more information." | |
| 430 (interactive (face-interactive "font")) | |
| 431 (set-face-property face 'font font locale tag-set how-to-add)) | |
| 432 | |
| 433 (defun face-foreground (face &optional locale tag-set exact-p) | |
| 434 "Return the foreground of the given face, or nil if it is unspecified. | |
| 435 | |
| 436 FACE may be either a face object or a symbol representing a face. | |
| 437 | |
| 438 LOCALE may be a locale (the instantiators for that particular locale | |
| 439 will be returned), a locale type (the specifications for all locales | |
| 440 of that type will be returned), 'all (all specifications will be | |
| 441 returned), or nil (the actual specifier object will be returned). | |
| 442 | |
| 443 See `face-property' for more information." | |
| 444 (face-property face 'foreground locale tag-set exact-p)) | |
| 445 | |
| 446 (defun face-foreground-instance (face &optional domain default no-fallback) | |
| 447 "Return the instance of the given face's foreground in the given domain. | |
| 448 | |
| 449 FACE may be either a face object or a symbol representing a face. | |
| 450 | |
| 451 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 452 and an instance object describing how the foreground appears in that | |
| 453 particular window and buffer will be returned. | |
| 454 | |
| 455 See `face-property-instance' for more information." | |
| 456 (face-property-instance face 'foreground domain default no-fallback)) | |
| 457 | |
| 458 (defun set-face-foreground (face color &optional locale tag-set how-to-add) | |
| 459 "Change the foreground of the given face. | |
| 460 | |
| 461 FACE may be either a face object or a symbol representing a face. | |
| 462 | |
| 463 COLOR should be an instantiator (see `color-specifier-p'), a list of | |
| 464 instantiators, an alist of specifications (each mapping a locale to | |
| 465 an instantiator list), or a color specifier object. | |
| 466 | |
| 467 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 468 specifier object, LOCALE can be a locale, a locale type, 'all, | |
| 469 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE | |
| 470 specifies the locale under which the specified instantiator(s) | |
| 471 will be added, and defaults to 'global. | |
| 472 | |
| 473 See `set-face-property' for more information." | |
| 474 (interactive (face-interactive "foreground")) | |
| 475 (set-face-property face 'foreground color locale tag-set how-to-add)) | |
| 476 | |
| 477 (defun face-background (face &optional locale tag-set exact-p) | |
| 478 "Return the background of the given face, or nil if it is unspecified. | |
| 479 | |
| 480 FACE may be either a face object or a symbol representing a face. | |
| 481 | |
| 482 LOCALE may be a locale (the instantiators for that particular locale | |
| 483 will be returned), a locale type (the specifications for all locales | |
| 484 of that type will be returned), 'all (all specifications will be | |
| 485 returned), or nil (the actual specifier object will be returned). | |
| 486 | |
| 487 See `face-property' for more information." | |
| 488 (face-property face 'background locale tag-set exact-p)) | |
| 489 | |
| 490 (defun face-background-instance (face &optional domain default no-fallback) | |
| 491 "Return the instance of the given face's background in the given domain. | |
| 492 | |
| 493 FACE may be either a face object or a symbol representing a face. | |
| 494 | |
| 495 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 496 and an instance object describing how the background appears in that | |
| 497 particular window and buffer will be returned. | |
| 498 | |
| 499 See `face-property-instance' for more information." | |
| 500 (face-property-instance face 'background domain default no-fallback)) | |
| 501 | |
| 502 (defun set-face-background (face color &optional locale tag-set how-to-add) | |
| 503 "Change the background of the given face. | |
| 504 | |
| 505 FACE may be either a face object or a symbol representing a face. | |
| 506 | |
| 507 COLOR should be an instantiator (see `color-specifier-p'), a list of | |
| 508 instantiators, an alist of specifications (each mapping a locale to | |
| 509 an instantiator list), or a color specifier object. | |
| 510 | |
| 511 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 512 specifier object, LOCALE can be a locale, a locale type, 'all, | |
| 513 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE | |
| 514 specifies the locale under which the specified instantiator(s) | |
| 515 will be added, and defaults to 'global. | |
| 516 | |
| 517 See `set-face-property' for more information." | |
| 518 (interactive (face-interactive "background")) | |
| 519 (set-face-property face 'background color locale tag-set how-to-add)) | |
| 520 | |
| 521 (defun face-background-pixmap (face &optional locale tag-set exact-p) | |
| 522 "Return the background pixmap of the given face, or nil if it is unspecified. | |
| 523 This property is only used on X devices. | |
| 524 | |
| 525 FACE may be either a face object or a symbol representing a face. | |
| 526 | |
| 527 LOCALE may be a locale (the instantiators for that particular locale | |
| 528 will be returned), a locale type (the specifications for all locales | |
| 529 of that type will be returned), 'all (all specifications will be | |
| 530 returned), or nil (the actual specifier object will be returned). | |
| 531 | |
| 532 See `face-property' for more information." | |
| 533 (face-property face 'background-pixmap locale tag-set exact-p)) | |
| 534 | |
| 535 (defun face-background-pixmap-instance (face &optional domain default | |
| 536 no-fallback) | |
| 537 "Return the instance of the given face's background pixmap in the given domain. | |
| 538 | |
| 539 FACE may be either a face object or a symbol representing a face. | |
| 540 | |
| 541 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 542 and an instance object describing how the background appears in that | |
| 543 particular window and buffer will be returned. | |
| 544 | |
| 545 See `face-property-instance' for more information." | |
| 546 (face-property-instance face 'background-pixmap domain default no-fallback)) | |
| 547 | |
| 548 (defun set-face-background-pixmap (face pixmap &optional locale tag-set | |
| 549 how-to-add) | |
| 550 "Change the background pixmap of the given face. | |
| 551 This property is only used on X devices. | |
| 552 | |
| 553 FACE may be either a face object or a symbol representing a face. | |
| 554 | |
| 555 PIXMAP should be an instantiator (see `image-specifier-p'), a list | |
| 556 of instantiators, an alist of specifications (each mapping a locale | |
| 557 to an instantiator list), or an image specifier object. | |
| 558 | |
| 559 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a | |
| 560 specifier object, LOCALE can be a locale, a locale type, 'all, | |
| 561 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE | |
| 562 specifies the locale under which the specified instantiator(s) | |
| 563 will be added, and defaults to 'global. | |
| 564 | |
| 565 See `set-face-property' for more information." | |
| 566 (interactive (face-interactive "background-pixmap")) | |
| 567 (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) | |
| 568 | |
| 569 (defun face-display-table (face &optional locale tag-set exact-p) | |
| 570 "Return the display table of the given face. | |
| 571 | |
| 572 A vector (as returned by `make-display-table') will be returned. | |
| 573 | |
| 574 LOCALE may be a locale (the instantiators for that particular locale | |
| 575 will be returned), a locale type (the specifications for all locales | |
| 576 of that type will be returned), 'all (all specifications will be | |
| 577 returned), or nil (the actual specifier object will be returned). | |
| 578 | |
| 579 See `face-property' for more information." | |
| 580 (face-property face 'display-table locale tag-set exact-p)) | |
| 581 | |
| 582 (defun face-display-table-instance (face &optional domain default no-fallback) | |
| 583 "Return the instance of FACE's display table in DOMAIN. | |
| 584 A vector (as returned by `make-display-table') will be returned. | |
| 585 | |
| 586 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 587 (face-property-instance face 'display-table domain default no-fallback)) | |
| 588 | |
| 589 (defun set-face-display-table (face display-table &optional locale tag-set | |
| 590 how-to-add) | |
| 591 "Change the display table of the given face. | |
| 592 DISPLAY-TABLE should be a vector as returned by `make-display-table'. | |
| 593 | |
| 594 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 595 HOW-TO-ADD arguments." | |
| 596 (interactive (face-interactive "display-table")) | |
| 597 (set-face-property face 'display-table display-table locale tag-set | |
| 598 how-to-add)) | |
| 599 | |
| 600 (defun face-underline-p (face &optional domain default no-fallback) | |
| 601 "Return whether the given face is underlined. | |
| 602 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 603 (face-property-instance face 'underline domain default no-fallback)) | |
| 604 | |
| 605 (defun set-face-underline-p (face underline-p &optional locale tag-set | |
| 606 how-to-add) | |
| 607 "Change whether the given face is underlined. | |
| 608 UNDERLINE-P is normally a face-boolean instantiator; see | |
| 609 `face-boolean-specifier-p'. | |
| 610 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 611 HOW-TO-ADD arguments." | |
| 612 (interactive (face-interactive "underline-p" "underlined")) | |
| 613 (set-face-property face 'underline underline-p locale tag-set how-to-add)) | |
| 614 | |
| 615 (defun face-strikethru-p (face &optional domain default no-fallback) | |
| 616 "Return whether the given face is strikethru-d (i.e. struck through). | |
| 617 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 618 (face-property-instance face 'strikethru domain default no-fallback)) | |
| 619 | |
| 620 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set | |
| 621 how-to-add) | |
| 622 "Change whether the given face is strikethru-d (i.e. struck through). | |
| 623 STRIKETHRU-P is normally a face-boolean instantiator; see | |
| 624 `face-boolean-specifier-p'. | |
| 625 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 626 HOW-TO-ADD arguments." | |
| 627 (interactive (face-interactive "strikethru-p" "strikethru-d")) | |
| 628 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) | |
| 629 | |
| 630 (defun face-highlight-p (face &optional domain default no-fallback) | |
| 631 "Return whether the given face is highlighted (TTY domains only). | |
| 632 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 633 (face-property-instance face 'highlight domain default no-fallback)) | |
| 634 | |
| 635 (defun set-face-highlight-p (face highlight-p &optional locale tag-set | |
| 636 how-to-add) | |
| 637 "Change whether the given face is highlighted (TTY locales only). | |
| 638 HIGHLIGHT-P is normally a face-boolean instantiator; see | |
| 639 `face-boolean-specifier-p'. | |
| 640 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 641 HOW-TO-ADD arguments." | |
| 642 (interactive (face-interactive "highlight-p" "highlighted")) | |
| 643 (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) | |
| 644 | |
| 645 (defun face-dim-p (face &optional domain default no-fallback) | |
| 646 "Return whether the given face is dimmed (TTY domains only). | |
| 647 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 648 (face-property-instance face 'dim domain default no-fallback)) | |
| 649 | |
| 650 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) | |
| 651 "Change whether the given face is dimmed (TTY locales only). | |
| 652 DIM-P is normally a face-boolean instantiator; see | |
| 653 `face-boolean-specifier-p'. | |
| 654 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 655 HOW-TO-ADD arguments." | |
| 656 (interactive (face-interactive "dim-p" "dimmed")) | |
| 657 (set-face-property face 'dim dim-p locale tag-set how-to-add)) | |
| 658 | |
| 659 (defun face-blinking-p (face &optional domain default no-fallback) | |
| 660 "Return whether the given face is blinking (TTY domains only). | |
| 661 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 662 (face-property-instance face 'blinking domain default no-fallback)) | |
| 663 | |
| 664 (defun set-face-blinking-p (face blinking-p &optional locale tag-set | |
| 665 how-to-add) | |
| 666 "Change whether the given face is blinking (TTY locales only). | |
| 667 BLINKING-P is normally a face-boolean instantiator; see | |
| 668 `face-boolean-specifier-p'. | |
| 669 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 670 HOW-TO-ADD arguments." | |
| 671 (interactive (face-interactive "blinking-p" "blinking")) | |
| 672 (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) | |
| 673 | |
| 674 (defun face-reverse-p (face &optional domain default no-fallback) | |
| 675 "Return whether the given face is reversed (TTY domains only). | |
| 676 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 677 (face-property-instance face 'reverse domain default no-fallback)) | |
| 678 | |
| 679 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) | |
| 680 "Change whether the given face is reversed (TTY locales only). | |
| 681 REVERSE-P is normally a face-boolean instantiator; see | |
| 682 `face-boolean-specifier-p'. | |
| 683 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 684 HOW-TO-ADD arguments." | |
| 685 (interactive (face-interactive "reverse-p" "reversed")) | |
| 686 (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) | |
| 687 | |
| 688 | |
| 689 (defun face-property-equal (face1 face2 prop domain) | |
| 690 (equal (face-property-instance face1 prop domain) | |
| 691 (face-property-instance face2 prop domain))) | |
| 692 | |
| 693 (defun face-equal-loop (props face1 face2 domain) | |
| 694 (while (and props | |
| 695 (face-property-equal face1 face2 (car props) domain)) | |
| 696 (setq props (cdr props))) | |
| 697 (null props)) | |
| 698 | |
| 699 (defun face-equal (face1 face2 &optional domain) | |
| 700 "True if the given faces will display in the the same way. | |
| 701 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 702 (if (null domain) (setq domain (selected-window))) | |
| 703 (if (not (valid-specifier-domain-p domain)) | |
| 704 (error "Invalid specifier domain")) | |
| 705 (let ((device (dfw-device domain)) | |
| 706 (common-props '(foreground background font display-table underline)) | |
| 707 (x-props '(background-pixmap strikethru)) | |
| 708 (tty-props '(highlight dim blinking reverse))) | |
| 709 | |
| 710 ;; First check the properties which are used in common between the | |
| 711 ;; x and tty devices. Then, check those properties specific to | |
| 712 ;; the particular device type. | |
| 713 (and (face-equal-loop common-props face1 face2 domain) | |
| 714 (cond ((eq 'tty (device-type device)) | |
| 715 (face-equal-loop tty-props face1 face2 domain)) | |
| 716 ((eq 'x (device-type device)) | |
| 717 (face-equal-loop x-props face1 face2 domain)) | |
| 718 (t t))))) | |
| 719 | |
| 720 (defun face-differs-from-default-p (face &optional domain) | |
| 721 "True if the given face will display differently from the default face. | |
| 722 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 723 (not (face-equal face 'default domain))) | |
| 724 | |
| 725 | |
| 726 ;; This function is a terrible, disgusting hack!!!! Need to | |
| 727 ;; separate out the font elements as separate face properties! | |
| 728 | |
| 729 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 730 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 731 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 732 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 733 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 734 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 735 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 736 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 737 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 738 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 739 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 740 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 741 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 742 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 743 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 744 (defun frob-face-property (face property func &optional locale) | |
| 745 "Change the specifier for FACE's PROPERTY according to FUNC, in LOCALE. | |
| 746 This function is ugly and messy and is primarily used as an internal | |
| 747 helper function for `make-face-bold' et al., so you probably don't | |
| 748 want to use it or read the rest of the documentation. But if you do ... | |
| 749 | |
| 750 FUNC should be a function of two arguments (an instance and a device) | |
| 751 that returns a modified name that is valid for the given device. | |
| 752 If LOCALE specifies a valid domain (i.e. a window, frame, or device), | |
| 753 this function instantiates the specifier over that domain, applies FUNC | |
| 754 to the resulting instance, and adds the result back as an instantiator | |
| 755 for that locale. Otherwise, LOCALE should be a locale, locale type, or | |
| 756 'all (defaults to 'all if omitted). For each specification thusly | |
| 757 included: if the locale given is a valid domain, FUNC will be | |
| 758 iterated over all valid instantiators for the device of the domain | |
| 759 until a non-nil result is found (if there is no such result, the | |
| 760 first valid instantiator is used), and that result substituted for | |
| 761 the specification; otherwise, the process just outlined is | |
| 762 iterated over each existing device and the concatenated results | |
| 763 substituted for the specification." | |
| 764 (let ((sp (face-property face property))) | |
| 765 (if (valid-specifier-domain-p locale) | |
| 766 ;; this is easy. | |
| 767 (let* ((inst (face-property-instance face property locale)) | |
| 768 (name (and inst (funcall func inst (dfw-device locale))))) | |
| 769 (if name | |
| 770 (add-spec-to-specifier sp name locale))) | |
| 771 ;; otherwise, map over all specifications ... | |
| 772 ;; but first, some further kludging: | |
| 773 ;; (1) if we're frobbing the global property, make sure | |
| 774 ;; that something is there (copy from the default face, | |
| 775 ;; if necessary). Otherwise, something like | |
| 776 ;; (make-face-larger 'modeline) | |
| 777 ;; won't do anything at all if the modeline simply | |
| 778 ;; inherits its font from 'default. | |
| 779 ;; (2) if we're frobbing a particular locale, nothing would | |
| 780 ;; happen if that locale has no instantiators. So signal | |
| 781 ;; an error to indicate this. | |
| 782 (if (and (or (eq locale 'global) (eq locale 'all) (not locale)) | |
| 783 (not (face-property face property 'global))) | |
| 784 (copy-specifier (face-property 'default property) | |
| 785 (face-property face property) | |
| 786 'global)) | |
| 787 (if (and (valid-specifier-locale-p locale) | |
| 788 (not (face-property face property locale))) | |
| 789 (error "Property must have a specification in locale %S" locale)) | |
| 790 (map-specifier | |
| 791 sp | |
| 792 #'(lambda (sp locale inst-list func) | |
| 793 (let* ((device (dfw-device locale)) | |
| 794 ;; if a device can be derived from the locale, | |
| 795 ;; call frob-face-property-1 for that device. | |
| 796 ;; Otherwise map frob-face-property-1 over each device. | |
| 797 (result | |
| 798 (if device | |
| 799 (list (frob-face-property-1 sp device inst-list func)) | |
| 800 (mapcar #'(lambda (device) | |
| 801 (frob-face-property-1 sp device | |
| 802 inst-list func)) | |
| 803 (device-list)))) | |
| 804 new-result) | |
| 805 ;; remove duplicates and nils from the obtained list of | |
| 806 ;; instantiators. | |
| 807 (mapcar #'(lambda (arg) | |
| 808 (if (and arg (not (member arg new-result))) | |
| 809 (setq new-result (cons arg new-result)))) | |
| 810 result) | |
| 811 ;; add back in. | |
| 812 (add-spec-list-to-specifier sp | |
| 813 (list (cons locale new-result))) | |
| 814 ;; tell map-specifier to keep going. | |
| 815 nil)) | |
| 816 locale | |
| 817 func)))) | |
| 818 | |
| 819 (defun frob-face-property-1 (sp device inst-list func) | |
| 820 (let | |
| 821 (first-valid result) | |
| 822 (while (and inst-list (not result)) | |
| 823 (let* ((inst-pair (car inst-list)) | |
| 824 (tag-set (car inst-pair)) | |
| 825 (sp-inst (specifier-instance-from-inst-list | |
| 826 sp device (list inst-pair)))) | |
| 827 (if sp-inst | |
| 828 (progn | |
| 829 (if (not first-valid) | |
| 830 (setq first-valid inst-pair)) | |
| 831 (setq result (funcall func sp-inst device)) | |
| 832 (if result | |
| 833 (setq result (cons tag-set result)))))) | |
| 834 (setq inst-list (cdr inst-list))) | |
| 835 (or result first-valid))) | |
| 836 | |
| 837 (defun frob-face-font-2 (face locale unfrobbed-face frobbed-face | |
| 838 tty-thunk x-thunk standard-face-mapping) | |
| 839 ;; another kludge to make things more intuitive. If we're | |
| 840 ;; inheriting from a standard face in this locale, frob the | |
| 841 ;; inheritance as appropriate. Else, if, after the first X frobbing | |
| 842 ;; pass, the face hasn't changed and still looks like the standard | |
| 843 ;; unfrobbed face (e.g. 'default), make it inherit from the standard | |
| 844 ;; frobbed face (e.g. 'bold). Regardless of things, do the TTY | |
| 845 ;; frobbing. | |
| 846 | |
| 847 ;; yuck -- The LOCALE argument to make-face-bold is not actually a locale, | |
| 848 ;; but is a "locale, locale-type, or nil for all". So ... do our extra | |
| 849 ;; frobbing only if it's actually a locale; or for nil, do the frobbing | |
| 850 ;; on 'global. This specifier stuff needs some rethinking. | |
| 851 (let* ((the-locale (cond ((null locale) 'global) | |
| 852 ((valid-specifier-locale-p locale) locale) | |
| 853 (t nil))) | |
| 854 (specs (and the-locale (face-font face the-locale nil t))) | |
| 855 (change-it (and specs (cdr (assoc specs standard-face-mapping))))) | |
| 856 (if (and change-it | |
| 857 (not (memq (face-name (find-face face)) | |
| 858 '(default bold italic bold-italic)))) | |
| 859 (progn | |
| 860 (or (equal change-it t) | |
| 861 (set-face-property face 'font change-it the-locale)) | |
| 862 (funcall tty-thunk)) | |
| 863 (let* ((domain (cond ((null the-locale) nil) | |
| 864 ((valid-specifier-domain-p the-locale) the-locale) | |
| 865 ;; OK, this next one is truly a kludge, but | |
| 866 ;; it results in more intuitive behavior most | |
| 867 ;; of the time. (really!) | |
| 868 ((or (eq the-locale 'global) (eq the-locale 'all)) | |
| 869 (selected-device)) | |
| 870 (t nil))) | |
| 871 (inst (and domain (face-property-instance face 'font domain)))) | |
| 872 (funcall tty-thunk) | |
| 873 (funcall x-thunk) | |
| 874 ;; If it's reasonable to do the inherit-from-standard-face trick, | |
| 875 ;; and it's called for, then do it now. | |
| 876 (or (null domain) | |
| 877 (not (equal inst (face-property-instance face 'font domain))) | |
| 878 ;; don't do it for standard faces, or you'll get inheritance loops. | |
| 879 ;; #### This makes XEmacs seg fault! fix this bug. | |
| 880 (memq (face-name (find-face face)) | |
| 881 '(default bold italic bold-italic)) | |
| 882 (not (equal (face-property-instance face 'font domain) | |
| 883 (face-property-instance unfrobbed-face 'font domain))) | |
| 884 (set-face-property face 'font (vector frobbed-face) | |
| 885 the-locale)))))) | |
| 886 | |
| 887 (defun make-face-bold (face &optional locale) | |
| 888 "Make the face bold, if possible. | |
| 889 This will attempt to make the font bold for X locales and will set the | |
| 890 highlight flag for TTY locales. | |
| 891 | |
| 892 If LOCALE is nil, omitted, or `all', this will attempt to frob all | |
| 893 font specifications for FACE to make them appear bold. Similarly, if | |
| 894 LOCALE is a locale type, this frobs all font specifications for locales | |
| 895 of that type. If LOCALE is a particular locale, what happens depends on | |
| 896 what sort of locale is given. If you gave a device, frame, or window, | |
| 897 then it's always possible to determine what the font actually will be, | |
| 898 so this is determined and the resulting font is frobbed and added back as a | |
| 899 specification for this locale. If LOCALE is a buffer, however, you can't | |
| 900 determine what the font will actually be unless there's actually a | |
| 901 specification given for that particular buffer (otherwise, it depends | |
| 902 on what window and frame the buffer appears in, and might not even be | |
| 903 well-defined if the buffer appears multiple times in different places); | |
| 904 therefore you will get an error unless there's a specification for the | |
| 905 buffer. | |
| 906 | |
| 907 Finally, in some cases (specifically, when LOCALE is not a locale type), | |
| 908 if the frobbing didn't actually make the font look any different | |
| 909 \(this happens, for example, if your font specification is already bold | |
| 910 or has no bold equivalent), and currently looks like the font of the | |
| 911 'default face, it is set to inherit from the 'bold face. This is kludgy | |
| 912 but it makes `make-face-bold' have more intuitive behavior in many | |
| 913 circumstances." | |
| 914 (interactive (list (read-face-name "Make which face bold: "))) | |
| 915 (frob-face-font-2 | |
| 916 face locale 'default 'bold | |
| 917 #'(lambda () | |
| 918 ;; handle TTY specific entries | |
| 919 (if (featurep 'tty) | |
| 920 (set-face-highlight-p face t locale 'tty))) | |
| 921 #'(lambda () | |
| 922 ;; handle X specific entries | |
| 923 (frob-face-property face 'font 'x-make-font-bold locale)) | |
| 924 '(([default] . [bold]) | |
| 925 ([bold] . t) | |
| 926 ([italic] . [bold-italic]) | |
| 927 ([bold-italic] . t)))) | |
| 928 | |
| 929 (defun make-face-italic (face &optional locale) | |
| 930 "Make the face italic, if possible. | |
| 931 This will attempt to make the font italic for X locales and will set | |
| 932 the underline flag for TTY locales. | |
| 933 See `make-face-bold' for the semantics of the LOCALE argument and | |
| 934 for more specifics on exactly how this function works." | |
| 935 (interactive (list (read-face-name "Make which face italic: "))) | |
| 936 (frob-face-font-2 | |
| 937 face locale 'default 'italic | |
| 938 #'(lambda () | |
| 939 ;; handle TTY specific entries | |
| 940 (if (featurep 'tty) | |
| 941 (set-face-underline-p face t locale 'tty))) | |
| 942 #'(lambda () | |
| 943 ;; handle X specific entries | |
| 944 (frob-face-property face 'font 'x-make-font-italic locale)) | |
| 945 '(([default] . [italic]) | |
| 946 ([bold] . [bold-italic]) | |
| 947 ([italic] . t) | |
| 948 ([bold-italic] . t)))) | |
| 949 | |
| 950 (defun make-face-bold-italic (face &optional locale) | |
| 951 "Make the face bold and italic, if possible. | |
| 952 This will attempt to make the font bold-italic for X locales and will | |
| 953 set the highlight and underline flags for TTY locales. | |
| 954 See `make-face-bold' for the semantics of the LOCALE argument and | |
| 955 for more specifics on exactly how this function works." | |
| 956 (interactive (list (read-face-name "Make which face bold-italic: "))) | |
| 957 (frob-face-font-2 | |
| 958 face locale 'default 'bold-italic | |
| 959 #'(lambda () | |
| 960 ;; handle TTY specific entries | |
| 961 (if (featurep 'tty) | |
| 962 (progn | |
| 963 (set-face-highlight-p face t locale 'tty) | |
| 964 (set-face-underline-p face t locale 'tty)))) | |
| 965 #'(lambda () | |
| 966 ;; handle X specific entries | |
| 967 (frob-face-property face 'font 'x-make-font-bold-italic locale)) | |
| 968 '(([default] . [italic]) | |
| 969 ([bold] . [bold-italic]) | |
| 970 ([italic] . [bold-italic]) | |
| 971 ([bold-italic] . t)))) | |
| 972 | |
| 973 (defun make-face-unbold (face &optional locale) | |
| 974 "Make the face non-bold, if possible. | |
| 975 This will attempt to make the font non-bold for X locales and will | |
| 976 unset the highlight flag for TTY locales. | |
| 977 See `make-face-bold' for the semantics of the LOCALE argument and | |
| 978 for more specifics on exactly how this function works." | |
| 979 (interactive (list (read-face-name "Make which face non-bold: "))) | |
| 980 (frob-face-font-2 | |
| 981 face locale 'bold 'default | |
| 982 #'(lambda () | |
| 983 ;; handle TTY specific entries | |
| 984 (if (featurep 'tty) | |
| 985 (set-face-highlight-p face nil locale 'tty))) | |
| 986 #'(lambda () | |
| 987 ;; handle X specific entries | |
| 988 (frob-face-property face 'font 'x-make-font-unbold locale)) | |
| 989 '(([default] . t) | |
| 990 ([bold] . [default]) | |
| 991 ([italic] . t) | |
| 992 ([bold-italic] . [italic])))) | |
| 993 | |
| 994 (defun make-face-unitalic (face &optional locale) | |
| 995 "Make the face non-italic, if possible. | |
| 996 This will attempt to make the font non-italic for X locales and will | |
| 997 unset the underline flag for TTY locales. | |
| 998 See `make-face-bold' for the semantics of the LOCALE argument and | |
| 999 for more specifics on exactly how this function works." | |
| 1000 (interactive (list (read-face-name "Make which face non-italic: "))) | |
| 1001 (frob-face-font-2 | |
| 1002 face locale 'italic 'default | |
| 1003 #'(lambda () | |
| 1004 ;; handle TTY specific entries | |
| 1005 (if (featurep 'tty) | |
| 1006 (set-face-underline-p face nil locale 'tty))) | |
| 1007 #'(lambda () | |
| 1008 ;; handle X specific entries | |
| 1009 (frob-face-property face 'font 'x-make-font-unitalic locale)) | |
| 1010 '(([default] . t) | |
| 1011 ([bold] . t) | |
| 1012 ([italic] . [default]) | |
| 1013 ([bold-italic] . [bold])))) | |
| 1014 | |
| 1015 (defun make-face-smaller (face &optional locale) | |
| 1016 "Make the font of the given face be smaller, if possible. | |
| 1017 LOCALE works as in `make-face-bold' et al., but the ``inheriting- | |
| 1018 from-the-bold-face'' operations described there are not done | |
| 1019 because they don't make sense in this context." | |
| 1020 (interactive (list (read-face-name "Shrink which face: "))) | |
| 1021 ;; handle X specific entries | |
| 1022 (frob-face-property face 'font 'x-find-smaller-font locale)) | |
| 1023 | |
| 1024 (defun make-face-larger (face &optional locale) | |
| 1025 "Make the font of the given face be larger, if possible. | |
| 1026 See `make-face-smaller' for the semantics of the LOCALE argument." | |
| 1027 (interactive (list (read-face-name "Enlarge which face: "))) | |
| 1028 ;; handle X specific entries | |
| 1029 (frob-face-property face 'font 'x-find-larger-font locale)) | |
| 1030 | |
| 1031 (defun invert-face (face &optional locale) | |
| 1032 "Swap the foreground and background colors of the face." | |
| 1033 (if (valid-specifier-domain-p locale) | |
| 1034 (let ((foreface (face-foreground-instance face locale))) | |
| 1035 (set-face-foreground face (face-background-instance face locale) | |
| 1036 locale) | |
| 1037 (set-face-background face foreface locale)) | |
| 1038 (let ((forespec (copy-specifier (face-foreground face) nil locale))) | |
| 1039 (copy-specifier (face-background face) (face-foreground face) locale) | |
| 1040 (copy-specifier forespec (face-background face) locale)))) | |
| 1041 | |
| 1042 | |
| 1043 ;;; Convenience functions | |
| 1044 | |
| 1045 (defun face-ascent (face &optional domain charset) | |
| 1046 "Return the ascent of a face. | |
| 1047 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1048 (font-ascent (face-font face) domain charset)) | |
| 1049 | |
| 1050 (defun face-descent (face &optional domain charset) | |
| 1051 "Return the descent of a face. | |
| 1052 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1053 (font-descent (face-font face) domain charset)) | |
| 1054 | |
| 1055 (defun face-width (face &optional domain charset) | |
| 1056 "Return the width of a face. | |
| 1057 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1058 (font-width (face-font face) domain charset)) | |
| 1059 | |
| 1060 (defun face-height (face &optional domain charset) | |
| 1061 "Return the height of a face. | |
| 1062 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1063 (+ (face-ascent face domain charset) (face-descent face domain charset))) | |
| 1064 | |
| 1065 (defun face-proportional-p (face &optional domain charset) | |
| 1066 "Return whether FACE is proportional. | |
| 1067 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1068 (font-proportional-p (face-font face) domain charset)) | |
| 1069 | |
| 1070 | |
| 1071 (defun init-face-from-resources (face &optional locale) | |
| 1072 "Initialize FACE from the resource database. | |
| 1073 If LOCALE is specified, it should be a frame, device, or 'global, and | |
| 1074 the face will be resourced over that locale. Otherwise, the face will | |
| 1075 be resourced over all possible locales (i.e. all frames, all devices, | |
| 1076 and 'global)." | |
| 1077 (if (not locale) | |
| 1078 (progn | |
| 1079 (init-face-from-resources face 'global) | |
| 1080 (let ((devices (device-list))) | |
| 1081 (while devices | |
| 1082 (init-face-from-resources face (car devices)) | |
| 1083 (setq devices (cdr devices)))) | |
| 1084 (let ((frames (frame-list))) | |
| 1085 (while frames | |
| 1086 (init-face-from-resources face (car frames)) | |
| 1087 (setq frames (cdr frames))))) | |
| 1088 (let ((devtype (cond ((devicep locale) (device-type locale)) | |
| 1089 ((framep locale) (frame-type locale)) | |
| 1090 (t nil)))) | |
| 1091 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) | |
| 1092 (x-init-face-from-resources face locale)) | |
| 1093 ((or (not devtype) (eq 'tty devtype)) | |
| 1094 ;; Nothing to do for TTYs? | |
| 1095 ))))) | |
| 1096 | |
| 1097 (defun init-device-faces (device) | |
| 1098 ;; First, add any device-local face resources. | |
| 1099 (let ((faces (face-list))) | |
| 1100 (while faces | |
| 1101 (init-face-from-resources (car faces) device) | |
| 1102 (setq faces (cdr faces)))) | |
| 1103 ;; Then do any device-specific initialization. | |
| 1104 (cond ((eq 'x (device-type device)) | |
| 1105 (x-init-device-faces device)) | |
| 1106 ;; Nothing to do for TTYs? | |
| 1107 ) | |
| 1108 (init-other-random-faces device)) | |
| 1109 | |
| 1110 (defun init-frame-faces (frame) | |
| 1111 ;; First, add any frame-local face resources. | |
| 1112 (let ((faces (face-list))) | |
| 1113 (while faces | |
| 1114 (init-face-from-resources (car faces) frame) | |
| 1115 (setq faces (cdr faces)))) | |
| 1116 ;; Then do any frame-specific initialization. | |
| 1117 (cond ((eq 'x (frame-type frame)) | |
| 1118 (x-init-frame-faces frame)) | |
| 1119 ;; Is there anything which should be done for TTY's? | |
| 1120 )) | |
| 1121 | |
| 1122 ;; #### This is somewhat X-specific, and is called when the first | |
| 1123 ;; X device is created (even if there were TTY devices created | |
| 1124 ;; beforehand). The concept of resources has not been generalized | |
| 1125 ;; outside of X-specificness, so we have to live with this | |
| 1126 ;; breach of device-independence. | |
| 1127 | |
| 1128 (defun init-global-faces () | |
| 1129 ;; Look for global face resources. | |
| 1130 (let ((faces (face-list))) | |
| 1131 (while faces | |
| 1132 (init-face-from-resources (car faces) 'global) | |
| 1133 (setq faces (cdr faces)))) | |
| 1134 ;; Further X frobbing. | |
| 1135 (x-init-global-faces) | |
| 1136 ;; for bold and the like, make the global specification be bold etc. | |
| 1137 ;; if the user didn't already specify a value. These will also be | |
| 1138 ;; frobbed further in init-other-random-faces. | |
| 1139 (or (face-font 'bold 'global) | |
| 1140 (make-face-bold 'bold 'global)) | |
| 1141 ;; | |
| 1142 (or (face-font 'italic 'global) | |
| 1143 (make-face-italic 'italic 'global)) | |
| 1144 ;; | |
| 1145 (or (face-font 'bold-italic 'global) | |
| 1146 (make-face-bold-italic 'bold-italic 'global)) | |
| 1147 | |
| 1148 (if (not (face-font 'bold-italic 'global)) | |
| 1149 (progn | |
| 1150 (copy-face 'bold 'bold-italic) | |
| 1151 (make-face-italic 'bold-italic))) | |
| 1152 | |
| 1153 (if (face-equal 'bold 'bold-italic) | |
| 1154 (progn | |
| 1155 (copy-face 'italic 'bold-italic) | |
| 1156 (make-face-bold 'bold-italic))) | |
| 1157 ;; | |
| 1158 ;; Nothing more to be done for X or TTY's? | |
| 1159 ) | |
| 1160 | |
| 1161 | |
| 1162 ;; These warnings are there for a reason. | |
| 1163 ;; Just specify your fonts correctly. Deal with it. | |
| 1164 ;(defvar inhibit-font-complaints nil | |
| 1165 ; "Whether to suppress complaints about incomplete sets of fonts.") | |
| 1166 | |
| 1167 (defun face-complain-about-font (face device) | |
| 1168 (if (symbolp face) (setq face (symbol-name face))) | |
| 1169 ;; (if (not inhibit-font-complaints) | |
| 1170 (display-warning | |
| 1171 'font | |
| 1172 (format "%s: couldn't deduce %s %s version of %S\n" | |
| 1173 invocation-name | |
| 1174 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") | |
| 1175 face | |
| 1176 (face-font-name 'default device))) | |
| 1177 ;; ) | |
| 1178 ) | |
| 1179 | |
| 1180 (defun init-other-random-faces (device) | |
| 1181 "Initializes the colors and fonts of the bold, italic, bold-italic, | |
| 1182 zmacs-region, list-mode-item-selected, highlight, primary-selection, | |
| 1183 secondary-selection, and isearch faces when each device is created. If | |
| 1184 you want to add code to do stuff like this, use the create-device-hook." | |
| 1185 | |
| 1186 ;; try to make 'bold look different from the default on this device. | |
| 1187 ;; If that doesn't work at all, then issue a warning. | |
| 1188 (or (face-differs-from-default-p 'bold device) | |
| 1189 (make-face-bold 'bold device)) | |
| 1190 (or (face-differs-from-default-p 'bold device) | |
| 1191 (make-face-unbold 'bold device)) | |
| 1192 (or (face-differs-from-default-p 'bold device) | |
| 1193 ;; otherwise the luser specified one of the bogus font names | |
| 1194 (face-complain-about-font 'bold device)) | |
| 1195 | |
| 1196 ;; similar for italic. | |
| 1197 (or (face-differs-from-default-p 'italic device) | |
| 1198 (make-face-italic 'italic device)) | |
| 1199 (or (face-differs-from-default-p 'italic device) | |
| 1200 (progn | |
| 1201 (make-face-bold 'bold device) ; bold if possible, then complain | |
| 1202 (face-complain-about-font 'italic device))) | |
| 1203 | |
| 1204 ;; similar for bold-italic. | |
| 1205 (or (face-differs-from-default-p 'bold-italic device) | |
| 1206 (make-face-bold-italic 'bold-italic device)) | |
| 1207 ;; if we couldn't get a bold-italic version, try just bold. | |
| 1208 (or (face-differs-from-default-p 'bold-italic device) | |
| 1209 (make-face-bold-italic 'bold-italic device)) | |
| 1210 ;; if we couldn't get bold or bold-italic, then that's probably because | |
| 1211 ;; the default font is bold, so make the `bold-italic' face be unbold. | |
| 1212 (or (face-differs-from-default-p 'bold-italic device) | |
| 1213 (progn | |
| 1214 (make-face-unbold 'bold-italic device) | |
| 1215 (make-face-italic 'bold-italic device))) | |
| 1216 (or (face-differs-from-default-p 'bold-italic device) | |
| 1217 (progn | |
| 1218 ;; if that didn't work, try italic (can this ever happen? what the hell.) | |
| 1219 (make-face-italic 'bold-italic device) | |
| 1220 ;; then bitch and moan. | |
| 1221 (face-complain-about-font 'bold-italic device))) | |
| 1222 | |
| 1223 ;; first time through, set the text-cursor colors if not already | |
| 1224 ;; specified. | |
| 1225 (if (and (not (face-background 'text-cursor 'global)) | |
| 1226 (face-property-equal 'text-cursor 'default 'background device)) | |
| 1227 (set-face-background 'text-cursor [default foreground] 'global | |
| 1228 nil 'append)) | |
| 1229 (if (and (not (face-foreground 'text-cursor 'global)) | |
| 1230 (face-property-equal 'text-cursor 'default 'foreground device)) | |
| 1231 (set-face-foreground 'text-cursor [default background] 'global | |
| 1232 nil 'append)) | |
| 1233 | |
| 1234 ;; first time through, set the secondary-selection color if it's not already | |
| 1235 ;; specified. | |
| 1236 (if (and (not (face-differs-from-default-p 'highlight device)) | |
| 1237 (not (face-background 'highlight 'global))) | |
| 1238 (progn | |
| 1239 ;; some older servers don't recognize "darkseagreen2" | |
| 1240 (set-face-background 'highlight | |
| 1241 '((color . "darkseagreen2") | |
| 1242 (color . "green")) | |
| 1243 'global nil 'append) | |
| 1244 (set-face-background 'highlight "gray53" 'global 'grayscale 'append))) | |
| 1245 (if (and (not (face-differs-from-default-p 'highlight device)) | |
| 1246 (not (face-background-pixmap 'highlight 'global))) | |
| 1247 (progn | |
| 1248 (set-face-background-pixmap 'highlight [nothing] 'global 'color | |
| 1249 'append) | |
| 1250 (set-face-background-pixmap 'highlight [nothing] 'global 'grayscale | |
| 1251 'append) | |
| 1252 (set-face-background-pixmap 'highlight "gray1" 'global 'mono 'append))) | |
| 1253 ;; if the highlight face isn't distinguished on this device, | |
| 1254 ;; at least try inverting it. | |
| 1255 (or (face-differs-from-default-p 'highlight device) | |
| 1256 (invert-face 'highlight device)) | |
| 1257 | |
| 1258 ;; first time through, set the zmacs-region color if it's not already | |
| 1259 ;; specified. | |
| 1260 (if (and (not (face-differs-from-default-p 'zmacs-region device)) | |
| 1261 (not (face-background 'zmacs-region 'global))) | |
| 1262 (progn | |
| 1263 (set-face-background 'zmacs-region "gray" 'global 'color) | |
| 1264 (set-face-background 'zmacs-region "gray80" 'global 'grayscale))) | |
| 1265 (if (and (not (face-differs-from-default-p 'zmacs-region device)) | |
| 1266 (not (face-background-pixmap 'zmacs-region 'global))) | |
| 1267 (progn | |
| 1268 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color) | |
| 1269 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale) | |
| 1270 (set-face-background-pixmap 'zmacs-region "gray3" 'global 'mono))) | |
| 1271 ;; if the zmacs-region face isn't distinguished on this device, | |
| 1272 ;; at least try inverting it. | |
| 1273 (or (face-differs-from-default-p 'zmacs-region device) | |
| 1274 (invert-face 'zmacs-region device)) | |
| 1275 | |
| 1276 ;; first time through, set the list-mode-item-selected color if it's | |
| 1277 ;; not already specified. | |
| 1278 (if (and (not (face-differs-from-default-p 'list-mode-item-selected device)) | |
| 1279 (not (face-background 'list-mode-item-selected 'global))) | |
| 1280 (progn | |
| 1281 (set-face-background 'list-mode-item-selected "gray68" 'global 'color) | |
| 1282 (set-face-background 'list-mode-item-selected "gray68" 'global | |
| 1283 'grayscale) | |
| 1284 (if (not (face-foreground 'list-mode-item-selected 'global)) | |
| 1285 (progn | |
| 1286 (set-face-background 'list-mode-item-selected | |
| 1287 [default foreground] 'global '(mono x)) | |
| 1288 (set-face-foreground 'list-mode-item-selected | |
| 1289 [default background] 'global '(mono x)))))) | |
| 1290 ;; if the list-mode-item-selected face isn't distinguished on this device, | |
| 1291 ;; at least try inverting it. | |
| 1292 (or (face-differs-from-default-p 'list-mode-item-selected device) | |
| 1293 (invert-face 'list-mode-item-selected device)) | |
| 1294 | |
| 1295 ;; first time through, set the primary-selection color if it's not already | |
| 1296 ;; specified. | |
| 1297 (if (and (not (face-differs-from-default-p 'primary-selection device)) | |
| 1298 (not (face-background 'primary-selection 'global))) | |
| 1299 (progn | |
| 1300 (set-face-background 'primary-selection "gray" 'global 'color) | |
| 1301 (set-face-background 'primary-selection "gray80" 'global 'grayscale))) | |
| 1302 (if (and (not (face-differs-from-default-p 'secondary-selection device)) | |
| 1303 (not (face-background-pixmap 'primary-selection 'global))) | |
| 1304 (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono)) | |
| 1305 ;; if the primary-selection face isn't distinguished on this device, | |
| 1306 ;; at least try inverting it. | |
| 1307 (or (face-differs-from-default-p 'primary-selection device) | |
| 1308 (invert-face 'primary-selection device)) | |
| 1309 | |
| 1310 ;; first time through, set the secondary-selection color if it's not already | |
| 1311 ;; specified. | |
| 1312 (if (and (not (face-differs-from-default-p 'secondary-selection device)) | |
| 1313 (not (face-background 'secondary-selection 'global))) | |
| 1314 (progn | |
| 1315 (set-face-background 'secondary-selection | |
| 1316 '((color . "paleturquoise") | |
| 1317 (color . "green")) | |
| 1318 'global) | |
| 1319 (set-face-background 'secondary-selection "gray53" 'global | |
| 1320 'grayscale))) | |
| 1321 (if (and (not (face-differs-from-default-p 'secondary-selection device)) | |
| 1322 (not (face-background-pixmap 'secondary-selection 'global))) | |
| 1323 (set-face-background-pixmap 'secondary-selection "gray1" 'global 'mono)) | |
| 1324 ;; if the secondary-selection face isn't distinguished on this device, | |
| 1325 ;; at least try inverting it. | |
| 1326 (or (face-differs-from-default-p 'secondary-selection device) | |
| 1327 (invert-face 'secondary-selection device)) | |
| 1328 | |
| 1329 ;; set the isearch color if it's not already specified. | |
| 1330 (if (not (face-differs-from-default-p 'isearch device)) | |
| 1331 (or (face-background 'isearch 'global) | |
| 1332 ;; TTY's and some older X servers don't recognize "paleturquoise" | |
| 1333 (set-face-background 'isearch | |
| 1334 '((color . "paleturquoise") | |
| 1335 (color . "green")) | |
| 1336 'global))) | |
| 1337 ;; if the isearch face isn't distinguished (e.g. we're not on a color | |
| 1338 ;; display), at least try making it bold. | |
| 1339 (or (face-differs-from-default-p 'isearch device) | |
| 1340 (set-face-font 'isearch [bold])) | |
| 1341 | |
| 1342 ;; set the modeline face colors/fonts if not already specified. | |
| 1343 | |
| 1344 ;; modeline-buffer-id: | |
| 1345 (if (not (face-differs-from-default-p 'modeline-buffer-id device)) | |
| 1346 (let ((fg (face-foreground 'modeline-buffer-id 'global)) | |
| 1347 (font (face-font 'modeline-buffer-id 'global))) | |
| 1348 (and (featurep 'x) | |
| 1349 (or fg | |
| 1350 (set-face-foreground 'modeline-buffer-id "blue" 'global | |
| 1351 '(color x)))) | |
| 1352 (if font | |
| 1353 nil | |
| 1354 (if (featurep 'x) | |
| 1355 (progn | |
| 1356 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x)) | |
| 1357 (set-face-font 'modeline-buffer-id [bold-italic] nil | |
| 1358 '(grayscale x)))) | |
| 1359 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)))) | |
| 1360 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append) | |
| 1361 | |
| 1362 ;; modeline-mousable: | |
| 1363 (if (not (face-differs-from-default-p 'modeline-mousable device)) | |
| 1364 (let ((fg (face-foreground 'modeline-mousable 'global)) | |
| 1365 (font (face-font 'modeline-mousable 'global))) | |
| 1366 (and (featurep 'x) | |
| 1367 (or fg | |
| 1368 (set-face-foreground 'modeline-mousable "red" 'global | |
| 1369 '(color x)))) | |
| 1370 (if font | |
| 1371 nil | |
| 1372 (if (featurep 'x) | |
| 1373 (progn | |
| 1374 (set-face-font 'modeline-mousable [bold] nil '(mono x)) | |
| 1375 (set-face-font 'modeline-mousable [bold] nil | |
| 1376 '(grayscale x))))))) | |
| 1377 (set-face-parent 'modeline-mousable 'modeline nil nil 'append) | |
| 1378 | |
| 1379 ;; modeline-mousable-minor-mode: | |
| 1380 (if (not (face-differs-from-default-p 'modeline-mousable-minor-mode device)) | |
| 1381 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global))) | |
| 1382 (and (featurep 'x) | |
| 1383 (or fg | |
| 1384 (set-face-foreground 'modeline-mousable-minor-mode | |
| 1385 '(((color x) . "green4") | |
| 1386 ((color x) . "green")) 'global))))) | |
| 1387 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable | |
| 1388 nil nil 'append) | |
| 1389 ) | |
| 1390 | |
| 1391 | |
| 1392 ;; Create the remaining standard faces now. This way, packages that we dump | |
| 1393 ;; can reference these faces as parents. | |
| 1394 ;; | |
| 1395 ;; The default, modeline, left-margin, right-margin, text-cursor, | |
| 1396 ;; and pointer faces are created in C. | |
| 1397 | |
| 1398 (make-face 'bold "bold text") | |
| 1399 (make-face 'italic "italic text") | |
| 1400 (make-face 'bold-italic "bold-italic text") | |
| 1401 (make-face 'underline "underlined text") | |
| 1402 (or (face-differs-from-default-p 'underline) | |
| 1403 (set-face-underline-p 'underline t 'global)) | |
| 1404 (make-face 'zmacs-region "used on defined region between point and mark") | |
| 1405 (make-face 'isearch "used on region matched by isearch") | |
| 1406 (make-face 'list-mode-item-selected | |
| 1407 "Face for the selected list item in list-mode.") | |
| 1408 (make-face 'highlight "highlight face") | |
| 1409 (make-face 'primary-selection) | |
| 1410 (make-face 'secondary-selection) | |
| 1411 | |
| 1412 (make-face 'red "red text") | |
| 1413 (set-face-foreground 'red "red" nil 'color) | |
| 1414 (make-face 'green "green text") | |
| 1415 (set-face-foreground 'green "green" nil 'color) | |
| 1416 (make-face 'blue "blue text") | |
| 1417 (set-face-foreground 'blue "blue" nil 'color) | |
| 1418 (make-face 'yellow "yellow text") | |
| 1419 (set-face-foreground 'yellow "yellow" nil 'color) | |
| 1420 | |
| 1421 ;; | |
| 1422 ;; Make some useful faces. This happens very early, before creating | |
| 1423 ;; the first non-stream device. We initialize the tty global values here. | |
| 1424 ;; We cannot initialize the X global values here because they depend | |
| 1425 ;; on having already resourced the global face specs, which happens | |
| 1426 ;; when the first X device is created. | |
| 1427 ;; | |
| 1428 | |
| 1429 (if (featurep 'tty) | |
| 1430 (set-face-reverse-p 'modeline t 'global 'tty)) | |
| 1431 (set-face-background-pixmap 'modeline [nothing]) | |
| 1432 ;; | |
| 1433 (if (featurep 'tty) | |
| 1434 (set-face-highlight-p 'highlight t 'global 'tty)) | |
| 1435 ;; | |
| 1436 (if (featurep 'tty) | |
| 1437 (set-face-reverse-p 'text-cursor t 'global 'tty)) | |
| 1438 ;; | |
| 1439 (if (featurep 'tty) | |
| 1440 (set-face-highlight-p 'bold t 'global 'tty)) | |
| 1441 ;; | |
| 1442 (if (featurep 'tty) | |
| 1443 (set-face-underline-p 'italic t 'global 'tty)) | |
| 1444 ;; | |
| 1445 (if (featurep 'tty) | |
| 1446 (progn | |
| 1447 (set-face-highlight-p 'bold-italic t 'global 'tty) | |
| 1448 (set-face-underline-p 'bold-italic t 'global 'tty))) | |
| 1449 ;; | |
| 1450 (if (featurep 'tty) | |
| 1451 (set-face-reverse-p 'zmacs-region t 'global 'tty)) | |
| 1452 ;; | |
| 1453 (if (featurep 'tty) | |
| 1454 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty)) | |
| 1455 ;; | |
| 1456 (if (featurep 'tty) | |
| 1457 (set-face-reverse-p 'isearch t 'global 'tty)) |