Mercurial > hg > xemacs-beta
annotate lisp/faces.el @ 5276:dd2976af8783
Add some missing #includes, termcap.c, hopefully fixing Adam Sjoegren's build.
2010-09-18 Aidan Kehoe <kehoea@parhasard.net>
* termcap.c:
Add a couple of missing includes here, which should fix builds
that use this file. (I have no access to such builds, but Mats'
buildbot shows output that indicates they fail at link time since
DEVICE_BAUD_RATE and IS_DIRECTORY_SEP are available.)
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 18 Sep 2010 15:03:54 +0100 |
| parents | 5502045ec510 |
| children | d27c1ee1943b 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; faces.el --- Lisp interface to the C "face" structure |
| 2 | |
| 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois | |
| 3027 | 5 ;; Copyright (C) 1995, 1996, 2002, 2005 Ben Wing |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
6 ;; Copyright (C) 2010 Didier Verna |
| 428 | 7 |
| 8 ;; Author: Ben Wing <ben@xemacs.org> | |
| 9 ;; Keywords: faces, internal, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
| 13 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 14 ;; under the terms of the GNU General Public License as published by | |
| 15 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 16 ;; any later version. | |
| 17 | |
| 18 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 21 ;; General Public License for more details. | |
| 22 | |
| 23 ;; You should have received a copy of the GNU General Public License | |
| 24 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 26 ;; Boston, MA 02111-1307, USA. | |
| 27 | |
| 28 ;;; Synched up with: Not synched with FSF. Almost completely divergent. | |
| 29 | |
| 30 ;;; Commentary: | |
| 31 | |
| 32 ;; This file is dumped with XEmacs. | |
| 33 | |
| 34 ;; face implementation #1 (used Lisp vectors and parallel C vectors; | |
| 35 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org> | |
| 36 ;; pre Lucid-Emacs 19.0. | |
| 37 | |
| 38 ;; face implementation #2 (used one face object per frame per face) | |
| 39 ;; authored by Jamie Zawinski for 19.9. | |
| 40 | |
| 41 ;; face implementation #3 (use one face object per face) originally | |
| 42 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, | |
| 43 ;; rewritten by Ben Wing with the advent of specifiers. | |
| 44 | |
| 45 | |
| 46 ;;; Some stuff in FSF's faces.el is in our x-faces.el. | |
| 47 | |
| 48 ;;; Code: | |
| 49 | |
| 771 | 50 ;; To elude the warnings for font functions. (Normally autoloaded when |
| 51 ;; font-create-object is called) | |
| 52 (eval-when-compile | |
| 3094 | 53 (require 'font) |
| 54 (load "cl-macs")) | |
| 771 | 55 |
| 428 | 56 (defgroup faces nil |
| 57 "Support for multiple text attributes (fonts, colors, ...) | |
| 58 Such a collection of attributes is called a \"face\"." | |
| 59 :group 'emacs) | |
| 60 | |
| 61 | |
| 62 (defun read-face-name (prompt) | |
| 63 (let (face) | |
| 64 (while (= (length face) 0) ; nil or "" | |
| 65 (setq face (completing-read prompt | |
| 66 (mapcar (lambda (x) (list (symbol-name x))) | |
| 67 (face-list)) | |
| 68 nil t))) | |
| 69 (intern face))) | |
| 70 | |
| 71 (defun face-interactive (what &optional bool) | |
| 72 (let* ((fn (intern (concat "face-" what "-instance"))) | |
| 73 (face (read-face-name (format "Set %s of face: " what))) | |
| 74 (default (if (fboundp fn) | |
| 75 ;; #### we should distinguish here between | |
| 76 ;; explicitly setting the value to be the | |
| 77 ;; same as the default face's value, and | |
| 78 ;; not setting a value at all. | |
| 79 (funcall fn face))) | |
| 80 (value (if bool | |
| 81 (y-or-n-p (format "Should face %s be %s? " | |
| 82 (symbol-name face) bool)) | |
| 83 (read-string (format "Set %s of face %s to: " | |
| 84 what (symbol-name face)) | |
| 85 (cond ((font-instance-p default) | |
| 86 (font-instance-name default)) | |
| 87 ((color-instance-p default) | |
| 88 (color-instance-name default)) | |
| 89 ((image-instance-p default) | |
| 90 (image-instance-file-name default)) | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
91 ((face-background-placement-instance-p default) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
92 (symbol-name default)) |
| 428 | 93 (t default)))))) |
| 94 (list face (if (equal value "") nil value)))) | |
| 95 | |
| 96 (defconst built-in-face-specifiers | |
| 97 (built-in-face-specifiers) | |
| 98 "A list of the built-in face properties that are specifiers.") | |
| 99 | |
| 100 (defun face-property (face property &optional locale tag-set exact-p) | |
| 101 "Return FACE's value of the given PROPERTY. | |
| 102 | |
| 3027 | 103 NOTE: If you are looking for the \"value\" of a built-in face property |
| 104 (`foreground', `background', `font', `background-pixmap', etc.), you | |
| 105 are probably better off calling `face-property-instance'. The return | |
| 106 value of `face-property' for built-in properties describes the original | |
| 107 specification used to determine the face property, which may be nil, | |
| 108 a list of instantiators, or something else that is unexpected. For | |
| 109 example, if you ask for a face property in a particular buffer (by | |
| 110 specifying a buffer for LOCALE), you will get a non-nil return value | |
| 111 only if a buffer-local specification for that particular buffer had | |
| 112 previously been given. | |
| 113 | |
| 114 For a full list of built-in property names and their semantics, see | |
| 115 `set-face-property'. | |
| 428 | 116 |
| 3027 | 117 If LOCALE is omitted, the FACE's actual value for PROPERTY will be |
| 118 returned. In this case, this function appears to behave rather | |
| 119 differently depending on whether PROPERTY is a built-in face property of | |
| 120 a user-defined face property. This is because the most basic value of a | |
| 121 user-defined property is simply whatever was set using | |
| 122 `set-face-property', but for a built-in property it's always a specifier, | |
| 123 which is an abstract object encapsulating all the specifications for that | |
| 124 particular property. | |
| 125 | |
| 126 LOCALE, if supplied, will generally be a buffer, frame or | |
| 127 `global' (for the global value), but there are other possibilities -- see | |
| 128 the following paragraph. This mostly applies to built-in properties. In | |
| 129 this case, the return value will not be a specifier object but the | |
| 130 specification(s) for the given locale or locale type will be returned | |
| 131 (equivalent to calling `specifier-specs' on the specifier). | |
| 132 (Technically, the same thing happens if the basic value of a user- | |
| 133 defined property is a specifier, although this usage is rare.) | |
| 428 | 134 |
| 135 The return value will be a list of instantiators (e.g. strings | |
| 136 specifying a font or color name), or a list of specifications, each | |
| 137 of which is a cons of a locale and a list of instantiators. | |
| 138 Specifically, if LOCALE is a particular locale (a buffer, window, | |
| 3027 | 139 frame, device, or `global'), a list of instantiators for that locale |
| 428 | 140 will be returned. Otherwise, if LOCALE is a locale type (one of |
| 3027 | 141 the symbols `buffer', `window', `frame', or `device'), the specifications |
| 428 | 142 for all locales of that type will be returned. Finally, if LOCALE is |
| 3027 | 143 `all', the specifications for all locales of all types will be returned. |
| 428 | 144 |
| 145 The specifications in a specifier determine what the value of | |
| 146 PROPERTY will be in a particular \"domain\" or set of circumstances, | |
| 3027 | 147 which is typically a particular Emacs window -- which in turn defines |
| 148 a buffer (the buffer in the window), a frame (the frame that the window | |
| 149 is in), and a device (the device that the frame is in). The value is | |
| 442 | 150 derived from the instantiator associated with the most specific |
| 3027 | 151 locale (in the order buffer, window, frame, device, and `global') |
| 428 | 152 that matches the domain in question. In other words, given a domain |
| 442 | 153 (i.e. an Emacs window, usually), the specifier for PROPERTY will |
| 154 first be searched for a specification whose locale is the buffer | |
| 155 contained within that window; then for a specification whose locale | |
| 156 is the window itself; then for a specification whose locale is the | |
| 157 frame that the window is contained within; etc. The first | |
| 158 instantiator that is valid for the domain (usually this means that | |
| 159 the instantiator is recognized by the device [i.e. MS Windows, the X | |
| 3027 | 160 server or TTY device]) will be \"instantiated\", which generates |
| 161 a Lisp object encapsulating the original instantiator and the underlying | |
| 162 window-system object describing the property. The function | |
| 163 `face-property-instance' actually does all this." | |
| 428 | 164 |
| 165 (setq face (get-face face)) | |
| 166 (let ((value (get face property))) | |
| 167 (if (and locale | |
| 168 (or (memq property built-in-face-specifiers) | |
| 169 (specifierp value))) | |
| 170 (setq value (specifier-specs value locale tag-set exact-p))) | |
| 171 value)) | |
| 172 | |
| 173 (defun convert-face-property-into-specifier (face property) | |
| 174 "Convert PROPERTY on FACE into a specifier, if it's not already." | |
| 175 (setq face (get-face face)) | |
| 176 (let ((specifier (get face property))) | |
| 177 ;; if a user-property does not have a specifier but a | |
| 178 ;; locale was specified, put a specifier there. | |
| 179 ;; If there was already a value there, convert it to a | |
| 3027 | 180 ;; specifier with the value as its `global' instantiator. |
| 428 | 181 (unless (specifierp specifier) |
| 182 (let ((new-specifier (make-specifier 'generic))) | |
| 183 (if (or (not (null specifier)) | |
| 184 ;; make sure the nil returned from `get' wasn't | |
| 185 ;; actually the value of the property | |
| 186 (null (get face property t))) | |
| 187 (add-spec-to-specifier new-specifier specifier)) | |
| 188 (setq specifier new-specifier) | |
| 189 (put face property specifier))))) | |
| 190 | |
| 191 (defun face-property-instance (face property | |
| 872 | 192 &optional domain default no-fallback) |
| 428 | 193 "Return the instance of FACE's PROPERTY in the specified DOMAIN. |
| 194 | |
| 195 Under most circumstances, DOMAIN will be a particular window, | |
| 196 and the returned instance describes how the specified property | |
| 197 actually is displayed for that window and the particular buffer | |
| 198 in it. Note that this may not be the same as how the property | |
| 199 appears when the buffer is displayed in a different window or | |
| 200 frame, or how the property appears in the same window if you | |
| 201 switch to another buffer in that window; and in those cases, | |
| 202 the returned instance would be different. | |
| 203 | |
| 204 The returned instance will typically be a color-instance, | |
| 3027 | 205 font-instance, or image-instance object, and you can query |
| 428 | 206 it using the appropriate object-specific functions. For example, |
| 207 you could use `color-instance-rgb-components' to find out the | |
| 3027 | 208 RGB (red, green, and blue) components of how the `background' |
| 209 property of the `highlight' face is displayed in a particular | |
| 428 | 210 window. The results might be different from the results |
| 211 you would get for another window (perhaps the user | |
| 212 specified a different color for the frame that window is on; | |
| 213 or perhaps the same color was specified but the window is | |
| 214 on a different X server, and that X server has different RGB | |
| 215 values for the color from this one). | |
| 216 | |
| 217 DOMAIN defaults to the selected window if omitted. | |
| 218 | |
| 219 DOMAIN can be a frame or device, instead of a window. The value | |
| 220 returned for a such a domain is used in special circumstances | |
| 221 when a more specific domain does not apply; for example, a frame | |
| 222 value might be used for coloring a toolbar, which is conceptually | |
| 223 attached to a frame rather than a particular window. The value | |
| 224 is also useful in determining what the value would be for a | |
| 225 particular window within the frame or device, if it is not | |
| 226 overridden by a more specific specification. | |
| 227 | |
| 228 If PROPERTY does not name a built-in property, its value will | |
| 229 simply be returned unless it is a specifier object, in which case | |
| 230 it will be instanced using `specifier-instance'. | |
| 231 | |
| 232 Optional arguments DEFAULT and NO-FALLBACK are the same as in | |
| 233 `specifier-instance'." | |
| 234 | |
| 235 (setq face (get-face face)) | |
| 236 (let ((value (get face property))) | |
| 237 (if (specifierp value) | |
| 238 (setq value (specifier-instance value domain default no-fallback))) | |
| 239 value)) | |
| 240 | |
| 241 (defun face-property-matching-instance (face property matchspec | |
| 872 | 242 &optional domain default |
| 243 no-fallback) | |
| 428 | 244 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. |
| 245 Currently the only useful value for MATCHSPEC is a charset, when used | |
| 246 in conjunction with the face's font; this allows you to retrieve a | |
| 247 font that can be used to display a particular charset, rather than just | |
| 248 any font. | |
| 249 | |
| 250 Other than MATCHSPEC, this function is identical to `face-property-instance'. | |
| 251 See also `specifier-matching-instance' for a fuller description of the | |
| 252 matching process." | |
| 253 | |
| 254 (setq face (get-face face)) | |
| 255 (let ((value (get face property))) | |
| 3659 | 256 (when (specifierp value) |
| 257 (setq value (specifier-matching-instance value matchspec domain | |
| 258 default no-fallback))) | |
| 428 | 259 value)) |
| 260 | |
| 261 (defun set-face-property (face property value &optional locale tag-set | |
| 872 | 262 how-to-add) |
| 428 | 263 "Change a property of FACE. |
| 264 | |
| 265 NOTE: If you want to remove a property from a face, use `remove-face-property' | |
| 266 rather than attempting to set a value of nil for the property. | |
| 267 | |
| 268 For built-in properties, the actual value of the property is a | |
| 269 specifier and you cannot change this; but you can change the | |
| 270 specifications within the specifier, and that is what this function | |
| 271 will do. For user-defined properties, you can use this function | |
| 272 to either change the actual value of the property or, if this value | |
| 273 is a specifier, change the specifications within it. | |
| 274 | |
| 275 If PROPERTY is a built-in property, the specifications to be added to | |
| 276 this property can be supplied in many different ways: | |
| 277 | |
| 278 -- If VALUE is a simple instantiator (e.g. a string naming a font or | |
| 279 color) or a list of instantiators, then the instantiator(s) will | |
| 280 be added as a specification of the property for the given LOCALE | |
| 3027 | 281 (which defaults to `global' if omitted). |
| 428 | 282 -- If VALUE is a list of specifications (each of which is a cons of |
| 283 a locale and a list of instantiators), then LOCALE must be nil | |
| 284 (it does not make sense to explicitly specify a locale in this | |
| 285 case), and specifications will be added as given. | |
| 286 -- If VALUE is a specifier (as would be returned by `face-property' | |
| 287 if no LOCALE argument is given), then some or all of the | |
| 288 specifications in the specifier will be added to the property. | |
| 289 In this case, the function is really equivalent to | |
| 290 `copy-specifier' and LOCALE has the same semantics (if it is | |
| 291 a particular locale, the specification for the locale will be | |
| 292 copied; if a locale type, specifications for all locales of | |
| 3027 | 293 that type will be copied; if nil or `all', then all |
| 428 | 294 specifications will be copied). |
| 295 | |
| 3027 | 296 HOW-TO-ADD should be either nil or one of the symbols `prepend', |
| 297 `append', `remove-tag-set-prepend', `remove-tag-set-append', `remove-locale', | |
| 298 `remove-locale-type', or `remove-all'. See `copy-specifier' and | |
| 428 | 299 `add-spec-to-specifier' for a description of what each of |
| 300 these means. Most of the time, you do not need to worry about | |
| 301 this argument; the default behavior usually is fine. | |
| 302 | |
| 303 In general, it is OK to pass an instance object (e.g. as returned | |
| 304 by `face-property-instance') as an instantiator in place of | |
| 305 an actual instantiator. In such a case, the instantiator used | |
| 306 to create that instance object will be used (for example, if | |
| 3027 | 307 you set a font-instance object as the value of the `font' |
| 428 | 308 property, then the font name used to create that object will |
| 309 be used instead). If some cases, however, doing this | |
| 310 conversion does not make sense, and this will be noted in | |
| 311 the documentation for particular types of instance objects. | |
| 312 | |
| 313 If PROPERTY is not a built-in property, then this function will | |
| 314 simply set its value if LOCALE is nil. However, if LOCALE is | |
| 315 given, then this function will attempt to add VALUE as the | |
| 316 instantiator for the given LOCALE, using `add-spec-to-specifier'. | |
| 317 If the value of the property is not a specifier, it will | |
| 3027 | 318 automatically be converted into a `generic' specifier. |
| 428 | 319 |
| 320 | |
| 321 The following symbols have predefined meanings: | |
| 322 | |
| 323 foreground The foreground color of the face. | |
| 442 | 324 For valid instantiators, see `make-color-specifier'. |
| 428 | 325 |
| 326 background The background color of the face. | |
| 442 | 327 For valid instantiators, see `make-color-specifier'. |
| 428 | 328 |
| 329 font The font used to display text covered by this face. | |
| 442 | 330 For valid instantiators, see `make-font-specifier'. |
| 428 | 331 |
| 332 display-table The display table of the face. | |
| 333 This should be a vector of 256 elements. | |
| 334 | |
| 335 background-pixmap The pixmap displayed in the background of the face. | |
| 442 | 336 Only used by faces on X and MS Windows devices. |
| 337 For valid instantiators, see `make-image-specifier'. | |
| 428 | 338 |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
339 background-placement The placement of the face's background pixmap. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
340 Only used by faces on X devices. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
341 For valid instantiators, |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
342 see `make-face-background-placement-specifier'. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
343 |
| 428 | 344 underline Underline all text covered by this face. |
| 442 | 345 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 346 |
| 347 strikethru Draw a line through all text covered by this face. | |
| 442 | 348 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 349 |
| 350 highlight Highlight all text covered by this face. | |
| 351 Only used by faces on TTY devices. | |
| 442 | 352 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 353 |
| 354 dim Dim all text covered by this face. | |
| 442 | 355 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 356 |
| 357 blinking Blink all text covered by this face. | |
| 358 Only used by faces on TTY devices. | |
| 442 | 359 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 360 |
| 361 reverse Reverse the foreground and background colors. | |
| 362 Only used by faces on TTY devices. | |
| 442 | 363 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 364 |
| 3027 | 365 inherit Face name or face object from which to inherit attributes, |
| 366 or a list of such elements. Attributes from inherited | |
| 367 faces are merged into the face like an underlying face | |
| 368 would be, with higher priority than underlying faces. | |
| 369 | |
| 428 | 370 doc-string Description of what the face's normal use is. |
| 371 NOTE: This is not a specifier, unlike all | |
| 372 the other built-in properties, and cannot | |
| 373 contain locale-specific values." | |
| 374 | |
| 375 (setq face (get-face face)) | |
| 376 (if (memq property built-in-face-specifiers) | |
| 377 (set-specifier (get face property) value locale tag-set how-to-add) | |
| 378 | |
| 379 ;; This section adds user defined properties. | |
| 380 (if (not locale) | |
| 381 (put face property value) | |
| 382 (convert-face-property-into-specifier face property) | |
| 383 (add-spec-to-specifier (get face property) value locale tag-set | |
| 384 how-to-add))) | |
| 385 value) | |
| 386 | |
| 387 (defun remove-face-property (face property &optional locale tag-set exact-p) | |
| 388 "Remove a property from FACE. | |
| 389 For built-in properties, this is analogous to `remove-specifier'. | |
| 390 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P | |
| 391 arguments." | |
| 392 (or locale (setq locale 'all)) | |
| 393 (if (memq property built-in-face-specifiers) | |
| 394 (remove-specifier (face-property face property) locale tag-set exact-p) | |
| 395 (if (eq locale 'all) | |
| 396 (remprop (get-face face) property) | |
| 397 (convert-face-property-into-specifier face property) | |
| 398 (remove-specifier (face-property face property) locale tag-set | |
| 399 exact-p)))) | |
| 400 | |
| 401 (defun reset-face (face &optional locale tag-set exact-p) | |
| 402 "Clear all existing built-in specifications from FACE. | |
| 3027 | 403 This makes FACE inherit all its display properties from `default'. |
| 428 | 404 WARNING: Be absolutely sure you want to do this!!! It is a dangerous |
| 405 operation and is not undoable. | |
| 406 | |
| 407 The arguments LOCALE, TAG-SET and EXACT-P are the same as for | |
| 408 `remove-specifier'." | |
| 3918 | 409 ;; Don't reset the default face. |
| 410 (unless (eq 'default face) | |
| 411 (dolist (x built-in-face-specifiers nil) | |
| 412 (remove-specifier (face-property face x) locale tag-set exact-p)))) | |
| 428 | 413 |
| 414 (defun set-face-parent (face parent &optional locale tag-set how-to-add) | |
| 415 "Set the parent of FACE to PARENT, for all properties. | |
| 416 This makes all properties of FACE inherit from PARENT." | |
| 417 (setq parent (get-face parent)) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
418 (mapc (lambda (x) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
419 (set-face-property face x (vector parent) locale tag-set |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
420 how-to-add)) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
421 (set-difference built-in-face-specifiers |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
422 '(display-table background-pixmap inherit))) |
| 428 | 423 (set-face-background-pixmap face (vector 'inherit ':face parent) |
| 424 locale tag-set how-to-add) | |
| 425 nil) | |
| 426 | |
| 427 (defun face-doc-string (face) | |
| 428 "Return the documentation string for FACE." | |
| 429 (face-property face 'doc-string)) | |
| 430 | |
| 431 (defun set-face-doc-string (face doc-string) | |
| 432 "Change the documentation string of FACE to DOC-STRING." | |
| 433 (interactive (face-interactive "doc-string")) | |
| 434 (set-face-property face 'doc-string doc-string)) | |
| 435 | |
| 436 (defun face-font-name (face &optional domain charset) | |
| 437 "Return the font name of FACE in DOMAIN, or nil if it is unspecified. | |
| 3027 | 438 DOMAIN is as in `face-font-instance'. |
| 439 | |
| 440 Font names are strings, as described in `make-font-specifier'." | |
| 428 | 441 (let ((f (face-font-instance face domain charset))) |
| 442 (and f (font-instance-name f)))) | |
| 443 | |
| 444 (defun face-font (face &optional locale tag-set exact-p) | |
| 3027 | 445 "Return the font spec of FACE in LOCALE, or nil if it is unspecified. |
| 446 | |
| 447 NOTE: This returns a locale-specific specification, not any sort of value | |
| 448 corresponding to the actual font being used. If you want to know the | |
| 449 actual font used in a particular domain, use `face-font-instance', or | |
| 450 `face-font-name' for its name (i.e. the instantiator used to create it). | |
| 428 | 451 |
| 452 FACE may be either a face object or a symbol representing a face. | |
| 453 | |
| 454 LOCALE may be a locale (the instantiators for that particular locale | |
| 455 will be returned), a locale type (the specifications for all locales | |
| 3027 | 456 of that type will be returned), `all' (all specifications will be |
| 428 | 457 returned), or nil (the actual specifier object will be returned). |
| 458 | |
| 459 See `face-property' for more information." | |
| 460 (face-property face 'font locale tag-set exact-p)) | |
| 461 | |
| 462 (defun face-font-instance (face &optional domain charset) | |
| 463 "Return the instance of FACE's font in DOMAIN. | |
| 464 | |
| 3027 | 465 Return value will be a font instance object; query its properties using |
| 466 `font-instance-name', `font-instance-height', `font-instance-width', etc. | |
| 467 | |
| 428 | 468 FACE may be either a face object or a symbol representing a face. |
| 469 | |
| 470 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 471 and an instance object describing how the font appears in that | |
| 472 particular window and buffer will be returned. | |
| 473 | |
| 3659 | 474 CHARSET is a Mule charset (meaning return the font used for that charset) or |
| 475 nil (meaning return the font used for ASCII.) | |
| 476 | |
| 428 | 477 See `face-property-instance' for more information." |
| 3659 | 478 (if (null charset) |
| 479 (face-property-instance face 'font domain) | |
| 480 (let (matchspec) | |
| 481 ;; get-charset signals an error if its argument doesn't have an | |
| 482 ;; associated charset. | |
| 4222 | 483 (setq charset (if-fboundp #'get-charset |
| 484 (get-charset charset) | |
| 485 (error 'unimplemented "Charset support not available")) | |
| 3659 | 486 matchspec (cons charset nil)) |
| 487 (or (null (setcdr matchspec 'initial)) | |
| 488 (face-property-matching-instance | |
| 489 face 'font matchspec domain) | |
| 490 (null (setcdr matchspec 'final)) | |
| 491 (face-property-matching-instance | |
| 492 face 'font matchspec domain))))) | |
| 428 | 493 |
| 494 (defun set-face-font (face font &optional locale tag-set how-to-add) | |
| 495 "Change the font of FACE to FONT in LOCALE. | |
| 496 | |
| 497 FACE may be either a face object or a symbol representing a face. | |
| 498 | |
| 3659 | 499 FONT should be an instantiator (see `make-font-specifier'; a common |
| 500 instantiator is a platform-dependent string naming the font), a list | |
| 501 of instantiators, an alist of specifications (each mapping a locale | |
| 502 to an instantiator list), or a font specifier object. | |
| 428 | 503 |
| 3659 | 504 If FONT is an alist, LOCALE must be omitted. If FONT is a specifier |
| 505 object, LOCALE can be a locale, a locale type, `all', or nil; see | |
| 506 `copy-specifier' for its semantics. Common LOCALEs are buffer | |
| 507 objects, window objects, device objects and `global'. Otherwise | |
| 508 LOCALE specifies the locale under which the specified | |
| 509 instantiator(s) will be added, and defaults to `global'. | |
| 428 | 510 |
| 511 See `set-face-property' for more information." | |
| 512 (interactive (face-interactive "font")) | |
| 513 (set-face-property face 'font font locale tag-set how-to-add)) | |
| 514 | |
| 515 (defun face-foreground (face &optional locale tag-set exact-p) | |
| 3027 | 516 "Return the foreground spec of FACE in LOCALE, or nil if it is unspecified. |
| 517 | |
| 518 NOTE: This returns a locale-specific specification, not any sort of value | |
| 519 corresponding to the actual foreground being used. If you want to know the | |
| 520 actual foreground color used in a particular domain, use | |
| 521 `face-foreground-instance', or `face-foreground-name' for its name | |
| 522 \(i.e. the instantiator used to create it). | |
| 428 | 523 |
| 524 FACE may be either a face object or a symbol representing a face. | |
| 525 | |
| 526 LOCALE may be a locale (the instantiators for that particular locale | |
| 527 will be returned), a locale type (the specifications for all locales | |
| 3027 | 528 of that type will be returned), `all' (all specifications will be |
| 428 | 529 returned), or nil (the actual specifier object will be returned). |
| 530 | |
| 531 See `face-property' for more information." | |
| 532 (face-property face 'foreground locale tag-set exact-p)) | |
| 533 | |
| 534 (defun face-foreground-instance (face &optional domain default no-fallback) | |
| 535 "Return the instance of FACE's foreground in DOMAIN. | |
| 536 | |
| 3027 | 537 Return value will be a color instance object; query its properties using |
| 538 `color-instance-name' or `color-instance-rgb-properties'. | |
| 539 | |
| 428 | 540 FACE may be either a face object or a symbol representing a face. |
| 541 | |
| 542 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 543 and an instance object describing how the foreground appears in that | |
| 544 particular window and buffer will be returned. | |
| 545 | |
| 546 See `face-property-instance' for more information." | |
| 547 (face-property-instance face 'foreground domain default no-fallback)) | |
| 548 | |
| 549 (defun face-foreground-name (face &optional domain default no-fallback) | |
| 550 "Return the name of FACE's foreground color in DOMAIN. | |
| 551 | |
| 552 FACE may be either a face object or a symbol representing a face. | |
| 553 | |
| 554 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 555 and an instance object describing how the background appears in that | |
| 556 particular window and buffer will be returned. | |
| 557 | |
| 558 See `face-property-instance' for more information." | |
| 559 (color-instance-name (face-foreground-instance | |
| 560 face domain default no-fallback))) | |
| 561 | |
| 562 (defun set-face-foreground (face color &optional locale tag-set how-to-add) | |
| 563 "Change the foreground color of FACE to COLOR in LOCALE. | |
| 564 | |
| 565 FACE may be either a face object or a symbol representing a face. | |
| 566 | |
| 442 | 567 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 568 instantiators, an alist of specifications (each mapping a locale to |
| 569 an instantiator list), or a color specifier object. | |
| 570 | |
| 571 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 572 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 573 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 574 specifies the locale under which the specified instantiator(s) | |
| 3027 | 575 will be added, and defaults to `global'. |
| 428 | 576 |
| 577 See `set-face-property' for more information." | |
| 578 (interactive (face-interactive "foreground")) | |
| 579 (set-face-property face 'foreground color locale tag-set how-to-add)) | |
| 580 | |
| 581 (defun face-background (face &optional locale tag-set exact-p) | |
| 582 "Return the background color of FACE in LOCALE, or nil if it is unspecified. | |
| 583 | |
| 3027 | 584 NOTE: This returns a locale-specific specification, not any sort of value |
| 585 corresponding to the actual background being used. If you want to know the | |
| 586 actual background color used in a particular domain, use | |
| 587 `face-background-instance', or `face-background-name' for its name | |
| 588 \(i.e. the instantiator used to create it). | |
| 589 | |
| 428 | 590 FACE may be either a face object or a symbol representing a face. |
| 591 | |
| 592 LOCALE may be a locale (the instantiators for that particular locale | |
| 593 will be returned), a locale type (the specifications for all locales | |
| 3027 | 594 of that type will be returned), `all' (all specifications will be |
| 428 | 595 returned), or nil (the actual specifier object will be returned). |
| 596 | |
| 597 See `face-property' for more information." | |
| 598 (face-property face 'background locale tag-set exact-p)) | |
| 599 | |
| 600 (defun face-background-instance (face &optional domain default no-fallback) | |
| 601 "Return the instance of FACE's background in DOMAIN. | |
| 602 | |
| 3027 | 603 Return value will be a color instance object; query its properties using |
| 604 `color-instance-name' or `color-instance-rgb-properties'. | |
| 605 | |
| 428 | 606 FACE may be either a face object or a symbol representing a face. |
| 607 | |
| 608 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 609 and an instance object describing how the background appears in that | |
| 610 particular window and buffer will be returned. | |
| 611 | |
| 612 See `face-property-instance' for more information." | |
| 613 (face-property-instance face 'background domain default no-fallback)) | |
| 614 | |
| 615 (defun face-background-name (face &optional domain default no-fallback) | |
| 616 "Return the name of FACE's background color in DOMAIN. | |
| 617 | |
| 618 FACE may be either a face object or a symbol representing a face. | |
| 619 | |
| 620 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 621 and an instance object describing how the background appears in that | |
| 622 particular window and buffer will be returned. | |
| 623 | |
| 624 See `face-property-instance' for more information." | |
| 625 (color-instance-name (face-background-instance | |
| 626 face domain default no-fallback))) | |
| 627 | |
| 628 (defun set-face-background (face color &optional locale tag-set how-to-add) | |
| 629 "Change the background color of FACE to COLOR in LOCALE. | |
| 630 | |
| 631 FACE may be either a face object or a symbol representing a face. | |
| 632 | |
| 442 | 633 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 634 instantiators, an alist of specifications (each mapping a locale to |
| 635 an instantiator list), or a color specifier object. | |
| 636 | |
| 637 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 638 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 639 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 640 specifies the locale under which the specified instantiator(s) | |
| 3027 | 641 will be added, and defaults to `global'. |
| 428 | 642 |
| 643 See `set-face-property' for more information." | |
| 644 (interactive (face-interactive "background")) | |
| 645 (set-face-property face 'background color locale tag-set how-to-add)) | |
| 646 | |
| 647 (defun face-background-pixmap (face &optional locale tag-set exact-p) | |
| 3027 | 648 "Return the background pixmap spec of FACE in LOCALE, or nil if unspecified. |
| 428 | 649 This property is only used on window system devices. |
| 650 | |
| 3027 | 651 NOTE: This returns a locale-specific specification, not any sort of value |
| 652 corresponding to the actual background pixmap being used. If you want to | |
| 653 know the actual background pixmap used in a particular domain, use | |
| 654 `face-background-pixmap-instance'. | |
| 655 | |
| 428 | 656 FACE may be either a face object or a symbol representing a face. |
| 657 | |
| 658 LOCALE may be a locale (the instantiators for that particular locale | |
| 659 will be returned), a locale type (the specifications for all locales | |
| 3027 | 660 of that type will be returned), `all' (all specifications will be |
| 428 | 661 returned), or nil (the actual specifier object will be returned). |
| 662 | |
| 663 See `face-property' for more information." | |
| 664 (face-property face 'background-pixmap locale tag-set exact-p)) | |
| 665 | |
| 666 (defun face-background-pixmap-instance (face &optional domain default | |
| 667 no-fallback) | |
| 668 "Return the instance of FACE's background pixmap in DOMAIN. | |
| 669 | |
| 3027 | 670 Return value will be an image instance object; query its properties using |
| 671 `image-instance-instantiator' (the original instantiator used to create | |
| 672 the image, which may be a complex beast -- see `make-image-specifier'), | |
| 673 `image-instance-file-name' (the file, if any, from which the image was | |
| 674 created), `image-instance-height', etc. | |
| 675 | |
| 428 | 676 FACE may be either a face object or a symbol representing a face. |
| 677 | |
| 678 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 679 and an instance object describing how the background appears in that | |
| 680 particular window and buffer will be returned. | |
| 681 | |
| 682 See `face-property-instance' for more information." | |
| 683 (face-property-instance face 'background-pixmap domain default no-fallback)) | |
| 684 | |
| 685 (defun set-face-background-pixmap (face pixmap &optional locale tag-set | |
| 686 how-to-add) | |
| 687 "Change the background pixmap of FACE to PIXMAP in LOCALE. | |
| 688 This property is only used on window system devices. | |
| 689 | |
| 690 FACE may be either a face object or a symbol representing a face. | |
| 691 | |
| 442 | 692 PIXMAP should be an instantiator (see `make-image-specifier'), a list |
| 428 | 693 of instantiators, an alist of specifications (each mapping a locale |
| 694 to an instantiator list), or an image specifier object. | |
| 695 | |
| 696 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a | |
| 3027 | 697 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 698 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 699 specifies the locale under which the specified instantiator(s) | |
| 3027 | 700 will be added, and defaults to `global'. |
| 428 | 701 |
| 702 See `set-face-property' for more information." | |
| 703 (interactive (face-interactive "background-pixmap")) | |
| 704 (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) | |
| 705 | |
| 1137 | 706 (defvar background-pixmap-file-history nil |
| 707 ;; History for `set-face-background-pixmap-file' | |
| 708 ) | |
| 709 | |
| 710 (defun set-face-background-pixmap-file (face file) | |
| 711 "Read (and set) the background pixmap of FACE from FILE. | |
| 712 This function is a simplified version of `set-face-background-pixmap', | |
| 713 designed for interactive use." | |
| 714 (interactive | |
| 715 (let* ((face (read-face-name "Set background pixmap of face: ")) | |
| 1139 | 716 (default (and (face-background-pixmap-instance face) |
|
4670
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
717 (image-instance-file-name |
|
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
718 (face-background-pixmap-instance face)))) |
| 1137 | 719 (file (read-file-name |
| 720 (format "Set background pixmap of face %s to: " | |
| 721 (symbol-name face)) | |
| 1139 | 722 nil default t nil |
| 1137 | 723 'background-pixmap-file-history))) |
| 724 (list face (if (equal file "") nil file)))) | |
| 725 (set-face-property face 'background-pixmap file)) | |
| 726 | |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
727 (defun face-background-placement (face &optional domain default no-fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
728 "Return FACE's background placement in DOMAIN. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
729 See `face-property-instance' for the semantics of the DOMAIN argument." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
730 (face-property face 'background-placement domain default no-fallback)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
731 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
732 (defun set-face-background-placement (face placement &optional locale tag-set |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
733 how-to-add) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
734 "Change the background-placement property of FACE to PLACEMENT. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
735 PLACEMENT is normally a background-placement instantiator; see |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
736 `make-face-background-placement-specifier'. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
737 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
738 HOW-TO-ADD arguments." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
739 (interactive (face-interactive "background placement")) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
740 ;; When called non-interactively (for example via custom), PLACEMENT is |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
741 ;; expected to be a symbol. -- dvl |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
742 (unless (symbolp placement) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
743 (setq placement (intern placement))) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
744 (set-face-property face 'background-placement placement locale tag-set |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
745 how-to-add)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
746 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
747 (defun face-background-placement-instance (face &optional domain default |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
748 no-fallback) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
749 "Return FACE's background-placement instance in DOMAIN. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
750 Return value will be a background-placement instance object. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
751 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
752 FACE may be either a face object or a symbol representing a face. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
753 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
754 Normally DOMAIN will be a window or nil (meaning the selected window), |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
755 and an instance object describing the background placement in that particular |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
756 window and buffer will be returned. |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
757 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
758 See `face-property-instance' for more information." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
759 (face-property-instance face 'background-placement domain default |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
760 no-fallback)) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
761 |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
762 (defun face-background-placement-instance-p (object) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
763 "Return t if OBJECT is a face-background-placement instance." |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
764 (or (eq object 'absolute) (eq object 'relative))) |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
765 |
| 428 | 766 (defun face-display-table (face &optional locale tag-set exact-p) |
| 3027 | 767 "Return the display table spec of FACE in LOCALE, or nil if unspecified.. |
| 428 | 768 |
| 3027 | 769 NOTE: This returns a locale-specific specification, not any sort of value |
| 770 corresponding to the actual display table being used. If you want to | |
| 771 know the actual display table used in a particular domain, use | |
| 772 `face-display-table-instance'. | |
| 773 | |
| 774 FACE may be either a face object or a symbol representing a face. | |
| 428 | 775 |
| 776 LOCALE may be a locale (the instantiators for that particular locale | |
| 777 will be returned), a locale type (the specifications for all locales | |
| 3027 | 778 of that type will be returned), `all' (all specifications will be |
| 428 | 779 returned), or nil (the actual specifier object will be returned). |
| 780 | |
| 781 See `face-property' for more information." | |
| 782 (face-property face 'display-table locale tag-set exact-p)) | |
| 783 | |
| 784 (defun face-display-table-instance (face &optional domain default no-fallback) | |
| 785 "Return the instance of FACE's display table in DOMAIN. | |
| 3027 | 786 |
| 787 Return value will be a vector, char table or range table; see | |
| 788 `current-display-table'. | |
| 789 | |
| 790 FACE may be either a face object or a symbol representing a face. | |
| 428 | 791 |
| 3027 | 792 Normally DOMAIN will be a window or nil (meaning the selected window), |
| 793 and the actual display table used in that particular window and buffer | |
| 794 will be returned. | |
| 795 | |
| 796 See `face-property-instance' for more information." | |
| 428 | 797 (face-property-instance face 'display-table domain default no-fallback)) |
| 798 | |
| 799 (defun set-face-display-table (face display-table &optional locale tag-set | |
| 872 | 800 how-to-add) |
| 428 | 801 "Change the display table of FACE to DISPLAY-TABLE in LOCALE. |
| 802 DISPLAY-TABLE should be a vector as returned by `make-display-table'. | |
| 803 | |
| 804 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 805 HOW-TO-ADD arguments." | |
| 806 (interactive (face-interactive "display-table")) | |
| 807 (set-face-property face 'display-table display-table locale tag-set | |
| 808 how-to-add)) | |
| 809 | |
| 810 ;; The following accessors and mutators are, IMHO, good | |
| 811 ;; implementation. Cf. with `make-face-bold'. | |
| 812 | |
| 813 (defun face-underline-p (face &optional domain default no-fallback) | |
| 814 "Return t if FACE is underlined in DOMAIN. | |
| 815 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 816 (face-property-instance face 'underline domain default no-fallback)) | |
| 817 | |
| 818 (defun set-face-underline-p (face underline-p &optional locale tag-set | |
| 872 | 819 how-to-add) |
| 428 | 820 "Change the underline property of FACE to UNDERLINE-P. |
| 821 UNDERLINE-P is normally a face-boolean instantiator; see | |
| 442 | 822 `make-face-boolean-specifier'. |
| 428 | 823 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 824 HOW-TO-ADD arguments." | |
| 825 (interactive (face-interactive "underline-p" "underlined")) | |
| 826 (set-face-property face 'underline underline-p locale tag-set how-to-add)) | |
| 827 | |
| 828 (defun face-strikethru-p (face &optional domain default no-fallback) | |
| 829 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN. | |
| 830 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 831 (face-property-instance face 'strikethru domain default no-fallback)) | |
| 832 | |
| 833 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set | |
| 872 | 834 how-to-add) |
| 428 | 835 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. |
| 836 STRIKETHRU-P is normally a face-boolean instantiator; see | |
| 442 | 837 `make-face-boolean-specifier'. |
| 428 | 838 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 839 HOW-TO-ADD arguments." | |
| 840 (interactive (face-interactive "strikethru-p" "strikethru-d")) | |
| 841 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) | |
| 842 | |
| 843 (defun face-highlight-p (face &optional domain default no-fallback) | |
| 844 "Return t if FACE is highlighted in DOMAIN (TTY domains only). | |
| 845 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 846 (face-property-instance face 'highlight domain default no-fallback)) | |
| 847 | |
| 848 (defun set-face-highlight-p (face highlight-p &optional locale tag-set | |
| 872 | 849 how-to-add) |
| 428 | 850 "Change whether FACE is highlighted in LOCALE (TTY locales only). |
| 851 HIGHLIGHT-P is normally a face-boolean instantiator; see | |
| 442 | 852 `make-face-boolean-specifier'. |
| 428 | 853 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 854 HOW-TO-ADD arguments." | |
| 855 (interactive (face-interactive "highlight-p" "highlighted")) | |
| 856 (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) | |
| 857 | |
| 858 (defun face-dim-p (face &optional domain default no-fallback) | |
| 859 "Return t if FACE is dimmed in DOMAIN. | |
| 860 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 861 (face-property-instance face 'dim domain default no-fallback)) | |
| 862 | |
| 863 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) | |
| 864 "Change whether FACE is dimmed in LOCALE. | |
| 865 DIM-P is normally a face-boolean instantiator; see | |
| 442 | 866 `make-face-boolean-specifier'. |
| 428 | 867 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 868 HOW-TO-ADD arguments." | |
| 869 (interactive (face-interactive "dim-p" "dimmed")) | |
| 870 (set-face-property face 'dim dim-p locale tag-set how-to-add)) | |
| 871 | |
| 872 (defun face-blinking-p (face &optional domain default no-fallback) | |
| 873 "Return t if FACE is blinking in DOMAIN (TTY domains only). | |
| 874 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 875 (face-property-instance face 'blinking domain default no-fallback)) | |
| 876 | |
| 877 (defun set-face-blinking-p (face blinking-p &optional locale tag-set | |
| 872 | 878 how-to-add) |
| 428 | 879 "Change whether FACE is blinking in LOCALE (TTY locales only). |
| 880 BLINKING-P is normally a face-boolean instantiator; see | |
| 442 | 881 `make-face-boolean-specifier'. |
| 428 | 882 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 883 HOW-TO-ADD arguments." | |
| 884 (interactive (face-interactive "blinking-p" "blinking")) | |
| 885 (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) | |
| 886 | |
| 887 (defun face-reverse-p (face &optional domain default no-fallback) | |
| 888 "Return t if FACE is reversed in DOMAIN (TTY domains only). | |
| 889 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 890 (face-property-instance face 'reverse domain default no-fallback)) | |
| 891 | |
| 892 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) | |
| 893 "Change whether FACE is reversed in LOCALE (TTY locales only). | |
| 894 REVERSE-P is normally a face-boolean instantiator; see | |
| 442 | 895 `make-face-boolean-specifier'. |
| 428 | 896 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 897 HOW-TO-ADD arguments." | |
| 898 (interactive (face-interactive "reverse-p" "reversed")) | |
| 899 (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) | |
| 900 | |
| 901 | |
| 902 (defun face-property-equal (face1 face2 prop domain) | |
| 903 (equal (face-property-instance face1 prop domain) | |
| 904 (face-property-instance face2 prop domain))) | |
| 905 | |
| 906 (defun face-equal-loop (props face1 face2 domain) | |
| 907 (while (and props | |
| 908 (face-property-equal face1 face2 (car props) domain)) | |
| 909 (setq props (cdr props))) | |
| 910 (null props)) | |
| 911 | |
| 912 (defun face-equal (face1 face2 &optional domain) | |
| 913 "Return t if FACE1 and FACE2 will display in the same way in DOMAIN. | |
| 914 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 915 (if (null domain) (setq domain (selected-window))) | |
| 916 (if (not (valid-specifier-domain-p domain)) | |
| 917 (error "Invalid specifier domain")) | |
| 918 (let ((device (dfw-device domain)) | |
| 919 (common-props '(foreground background font display-table underline | |
| 3027 | 920 dim inherit)) |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
921 (win-props '(background-pixmap background-placement strikethru)) |
| 428 | 922 (tty-props '(highlight blinking reverse))) |
| 923 | |
| 924 ;; First check the properties which are used in common between the | |
| 925 ;; x and tty devices. Then, check those properties specific to | |
| 926 ;; the particular device type. | |
| 927 (and (face-equal-loop common-props face1 face2 domain) | |
| 928 (cond ((eq 'tty (device-type device)) | |
| 929 (face-equal-loop tty-props face1 face2 domain)) | |
| 872 | 930 ((console-on-window-system-p (device-console device)) |
| 428 | 931 (face-equal-loop win-props face1 face2 domain)) |
| 932 (t t))))) | |
| 933 | |
| 934 (defun face-differs-from-default-p (face &optional domain) | |
| 935 "Return t if FACE will display differently from the default face in DOMAIN. | |
| 936 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 937 (not (face-equal face 'default domain))) | |
| 938 | |
| 939 (defun try-font-name (name &optional device) | |
| 872 | 940 "Return NAME if it's a valid font name on DEVICE, else nil." |
| 428 | 941 ;; yes, name really should be here twice. |
| 942 (and name (make-font-instance name device t) name)) | |
| 943 | |
| 944 | |
| 872 | 945 |
| 946 (defcustom face-frob-from-locale-first nil | |
| 947 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule | |
| 948 multi-charset environments." | |
| 949 :group 'faces | |
| 950 :type 'boolean) | |
| 951 | |
| 428 | 952 ;; This function is a terrible, disgusting hack!!!! Need to |
| 953 ;; separate out the font elements as separate face properties! | |
| 954 | |
| 955 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 956 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 957 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 958 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 959 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 960 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 961 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 962 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 963 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 964 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 965 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 966 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 967 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 968 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 969 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 872 | 970 |
| 971 ;; When we are initializing a device, it won't be selected; we communicate | |
| 972 ;; the device to consider as selected using this variable. | |
| 973 (defvar Face-frob-property-device-considered-current nil) | |
| 428 | 974 |
| 872 | 975 (defun Face-frob-property (face locale tag-set exact-p |
| 976 unfrobbed-face frobbed-face | |
| 977 win-prop tty-props | |
| 978 frob-mapping standard-face-mapping) | |
| 979 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET | |
| 980 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are | |
| 981 ;; what we expect the original face and the result to look like, | |
| 982 ;; respectively. TTY-PROPS is a list of face properties to frob in place | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
983 ;; of `font' for TTYs. FROB-MAPPING is either a plist mapping device |
| 872 | 984 ;; types to functions of two args (NAME DEVICE) that will frob the |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
985 ;; instantiator to NAME as appropriate for DEVICE's type (this includes |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
986 ;; TTYs #### TTYs are not passed the device, just the symbol 'tty), or a |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
987 ;; function to handle the mapping for all device types. |
| 872 | 988 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance |
| 989 ;; instantiators to be replaced with other inheritance instantiators, meant | |
| 990 ;; for e.g. converting [bold] into [bold-italic]. | |
| 991 | |
| 992 ;; #### it would be nice if this function could be generalized to be | |
| 993 ;; a general specifier frobber. but so much of what it does is specific | |
| 994 ;; to faces -- e.g. handling of inheritance, standard faces, | |
| 995 ;; special-casing in various ways for tty's, etc. i've already extracted | |
| 996 ;; as much of the functionality as i can into subfunctions in the | |
| 997 ;; heuristic section of specifier.el. | |
| 442 | 998 |
| 872 | 999 ;; #### Note: The old code was totally different (and there was much less |
| 1000 ;; of it). It didn't bother with trying to frob all the instantiators, | |
| 1001 ;; or handle inheritance vectors as instantiators, or do something | |
| 1002 ;; sensible with buffer locales, or many other things. (It always, or | |
| 1003 ;; usually, did a specifier-instance and frobbed the result.) But it did | |
| 1004 ;; do three things we don't: | |
| 1005 ;; | |
| 1006 ;; (1) Map over all devices when processing global or buffer locales. | |
| 1007 ;; Should we be doing this in stages 2 and/or 3? The fact that we | |
| 1008 ;; now process all fallback instantiators seems to make this less | |
| 1009 ;; necessary, at least for global locales. | |
| 1010 ;; | |
| 1011 ;; (2) Remove all instantiators tagged with `default' when putting the | |
| 1012 ;; instantiators back. I don't see why this is necessary, but maybe | |
| 1013 ;; it is. | |
| 1014 ;; | |
| 1015 ;; (3) Pay attention to the face-frob-from-locale-first variable. #### | |
| 1016 ;; I don't understand its purpose. Undocumented hacks like this, | |
| 1017 ;; clearly added after-the-fact, don't deserve to live. DOCUMENT | |
| 1018 ;; THIS SHIT! | |
| 428 | 1019 |
| 872 | 1020 (flet |
| 1021 ( | |
| 1022 | |
| 1023 ;; non-nil if either instantiator non-nil, or nil instantiators allowed. | |
| 1024 (nil-instantiator-ok (inst devtype-spec) | |
| 1025 (or inst (eq devtype-spec 'tty))) | |
| 1026 | |
| 1027 ;; if LOCALE is a global locale (all, nil, global), return 'global, | |
| 1028 ;; else nil. | |
| 1029 (global-locale (locale) | |
| 1030 (and (memq locale '(all nil global)) 'global)) | |
| 444 | 1031 |
| 872 | 1032 ;; Given a locale and the inst-list from that locale, frob the |
| 1033 ;; instantiators according to FROB-MAPPING, a plist mapping device | |
| 1034 ;; types to functions that frob instantiators of that device type. | |
| 1035 ;; NOTE: TAG-SET and FROB-MAPPING from environment. | |
| 1036 (frob-face-inst-list (locale inst-list prop devtype-spec) | |
| 1037 (let* ((ffpdev Face-frob-property-device-considered-current) | |
| 1038 (results | |
| 1039 ;; for each inst-pair, frob it (the result will be 0 or | |
| 1040 ;; more inst-pairs; we may get more than one if, e.g. the | |
| 1041 ;; instantiator specifies inheritance and we expand the | |
| 1042 ;; inheritance); then nconc the results together | |
| 1043 (loop for (tag-set . x) in inst-list | |
| 1044 for devtype = (derive-device-type-from-locale-and-tag-set | |
| 1045 locale tag-set devtype-spec ffpdev) | |
| 1046 ;; devtype may be nil if it fails to match DEVTYPE-SPEC | |
| 1047 if devtype | |
| 3360 | 1048 if (let* ((mapper |
| 1049 (cond ((functionp frob-mapping) frob-mapping) | |
| 1050 ((plist-get frob-mapping devtype)) | |
| 1051 (t (error 'unimplemented "mapper" devtype)))) | |
| 872 | 1052 (result |
| 1053 (cond | |
| 1054 ;; if a vector ... | |
| 1055 ((vectorp x) | |
| 1056 (let ((change-to | |
| 1057 (cdr (assoc x standard-face-mapping)))) | |
| 1058 (cond | |
| 1059 ;; (1) handle standard mappings/null vectors | |
| 1060 ((or change-to (null (length x))) | |
| 1061 (list (cons tag-set | |
| 1062 (cond ((eq change-to t) x) | |
| 1063 (change-to) | |
| 1064 (t x))))) | |
| 1065 ;; (2) inheritance vectors. retrieve the | |
| 1066 ;; inherited value and recursively frob. | |
| 1067 ;; stick the tag-set into the result. | |
| 1068 (t (let* | |
| 1069 ((subprop | |
| 1070 (if (> (length x) 1) (elt x 1) | |
| 1071 prop)) | |
| 1072 (subinsts | |
| 1073 (frob-face-inst-list | |
| 1074 locale | |
| 1075 (cdar | |
| 1076 (specifier-spec-list | |
| 1077 (face-property (elt x 0) | |
| 1078 subprop))) | |
| 1079 subprop devtype-spec))) | |
| 1080 ;; #### we don't currently handle | |
| 1081 ;; the "reverse the sense" flag on | |
| 1082 ;; tty inheritance vectors. | |
| 1083 (add-tag-to-inst-list subinsts | |
| 1084 tag-set)))))) | |
| 1085 ;; (3) not a vector. just process it. | |
| 1086 (t | |
| 1087 (let ((value | |
| 1088 (if (eq devtype-spec 'tty) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1089 ;; #### not quite right but need |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1090 ;; two args to match documentation |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1091 ;; mostly we just ignore TTYs so |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1092 ;; for now just pass the devtype |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1093 (funcall mapper x 'tty) |
| 872 | 1094 (funcall mapper x |
| 1095 (derive-domain-from-locale | |
| 1096 locale devtype-spec | |
| 1097 ffpdev))))) | |
| 1098 (and (nil-instantiator-ok value devtype-spec) | |
| 1099 (list (cons tag-set value)))))))) | |
| 1100 ;; if we're adding to a tty, we need to tag our | |
| 1101 ;; additions with `tty'; see [note 1] below. we leave | |
| 1102 ;; the old spec in place, however -- if e.g. we're | |
| 1103 ;; italicizing a font that was always set to be | |
| 1104 ;; underlined, even on window systems, then we still | |
| 1105 ;; want the underline there. unless we put the old | |
| 1106 ;; spec back, the underline will disappear, since | |
| 1107 ;; the new specs are all tagged with `tty'. this | |
| 1108 ;; doesn't apply to the [note 1] situations below | |
| 1109 ;; because there we're just adding, not substituting. | |
| 1110 (if (and (eq 'tty devtype-spec) | |
| 1111 (not (or (eq 'tty tag-set) | |
| 1112 (memq 'tty tag-set)))) | |
| 1113 (nconc (add-tag-to-inst-list result 'tty) | |
| 1114 (list (cons tag-set x))) | |
| 1115 result)) | |
| 1116 nconc it))) | |
| 1117 (delete-duplicates results :test #'equal))) | |
| 428 | 1118 |
| 872 | 1119 ;; Frob INST-LIST, which came from LOCALE, and put the new value back |
| 1120 ;; into SP at LOCALE. THUNK is a cons of (PROP . DEVTYPE-SPEC), the | |
| 1121 ;; property being processed and whether this is a TTY property or a | |
| 1122 ;; win property. | |
| 1123 (frob-locale (sp locale inst-list thunk) | |
| 1124 (let ((newinst (frob-face-inst-list locale inst-list | |
| 1125 (car thunk) (cdr thunk)))) | |
| 1126 (remove-specifier sp locale tag-set exact-p) | |
| 1127 (add-spec-list-to-specifier sp (list (cons locale newinst)))) | |
| 1128 ;; map-specifier should keep going | |
| 1129 nil) | |
| 428 | 1130 |
| 872 | 1131 ;; map over all specified locales in LOCALE; for each locale, |
| 1132 ;; frob the instantiators in that locale in the specifier in both | |
| 1133 ;; WIN-PROP and TTY-PROPS in FACE. Takes values from environment. | |
| 1134 (map-over-locales (locale) | |
| 1135 (map-specifier (get face win-prop) #'frob-locale locale | |
| 1136 (cons win-prop 'window-system) | |
| 1137 tag-set exact-p) | |
| 1138 (loop for prop in tty-props do | |
| 1139 (map-specifier (get face prop) #'frob-locale locale | |
| 1140 (cons prop 'tty) | |
| 1141 tag-set exact-p))) | |
| 1142 | |
| 1143 ;; end of flets | |
| 1144 ) | |
| 1145 | |
| 1146 ;; the function itself | |
| 452 | 1147 |
| 872 | 1148 (let* ((ffpdev Face-frob-property-device-considered-current) |
| 1149 (do-later-stages | |
| 1150 (or (global-locale locale) | |
| 1151 (valid-specifier-domain-p locale) | |
| 1152 (bufferp locale))) | |
| 1153 (domain (and do-later-stages | |
| 1154 (derive-domain-from-locale locale 'window-system | |
| 1155 ffpdev))) | |
| 1156 (check-differences | |
| 1157 (and unfrobbed-face frobbed-face domain | |
| 1158 (not (memq (face-name face) | |
| 1159 '(default bold italic bold-italic))))) | |
| 1160 (orig-instance | |
| 1161 (and check-differences | |
| 1162 (face-property-instance face win-prop domain)))) | |
| 1163 | |
| 1164 ;; first do the frobbing | |
| 1165 (setq face (get-face face)) | |
| 1166 (map-over-locales locale) | |
| 1167 | |
| 1168 (when do-later-stages | |
| 1169 | |
| 1170 (if (global-locale locale) (setq locale 'global)) | |
| 428 | 1171 |
| 872 | 1172 ;; now do the second stage -- if there's nothing there, try |
| 1173 ;; harder to find an instantiator, and frob it. | |
| 1174 (let (do-something) | |
| 1175 (loop for prop in (cons win-prop tty-props) | |
| 1176 for propspec = (get face prop) | |
| 1177 for devtype-spec = (if (eq prop win-prop) 'window-system 'tty) | |
| 1178 if propspec | |
| 1179 do | |
| 1180 (or (specifier-spec-list propspec locale) | |
| 1181 (let ((doit (derive-specifier-specs-from-locale | |
| 1182 propspec locale devtype-spec ffpdev | |
| 1183 ;; #### does this make sense? When no tags | |
| 1184 ;; given, frob the whole list of fallbacks when | |
| 1185 ;; global, else just retrieve a current-device | |
| 1186 ;; value. this tries to mirror normal practices, | |
| 1187 ;; where with no tags you want everything frobbed, | |
| 1188 ;; but with a tag you want only the tag frobbed | |
| 1189 ;; and hence you probably don't want lots and lots | |
| 1190 ;; of items there. (#### Perhaps the best way -- | |
| 1191 ;; or at least a way with some theoretical | |
| 1192 ;; justifiability -- is to fetch the fallbacks | |
| 1193 ;; that match the TAG-SET/EXACT-P, and if none, | |
| 1194 ;; fall back onto doing the selected-device | |
| 1195 ;; trick.) | |
| 1196 (and (not tag-set) (not exact-p))))) | |
| 1197 (if (and (not doit) (eq locale 'global)) | |
| 1198 (error | |
| 1199 "No fallback for specifier property %s in face %s???" | |
| 1200 prop face)) | |
| 1201 ;; [note 1] whenever we add to a tty property, | |
| 1202 ;; make sure we tag our additions with `tty' to | |
| 1203 ;; avoid accidentally messing things up on window | |
| 1204 ;; systems (e.g. when making things italic we | |
| 1205 ;; don't want to set the underline property on | |
| 1206 ;; window systems) | |
| 1207 (when doit | |
| 1208 (add-spec-list-to-specifier | |
| 1209 propspec | |
| 1210 (list (cons locale | |
| 1211 (add-tag-to-inst-list | |
| 1212 doit | |
| 1213 (append (if (listp tag-set) tag-set | |
| 1214 (list tag-set)) | |
| 1215 (if (eq devtype-spec 'tty) '(tty))) | |
| 1216 )))) | |
| 1217 (setq do-something t))))) | |
| 1218 (when do-something | |
| 1219 (map-over-locales (or (global-locale locale) locale)))) | |
| 1220 | |
| 1221 ;; then do the third stage -- check for whether we have to do | |
| 1222 ;; the inheritance trick. | |
| 1223 | |
| 1224 (when (and check-differences | |
| 1225 (let ((new-instance | |
| 1226 (face-property-instance face win-prop domain))) | |
| 1227 (and | |
| 1228 (equal orig-instance new-instance) | |
| 1229 (equal orig-instance | |
| 1230 (face-property-instance unfrobbed-face win-prop | |
| 1231 domain))))) | |
| 1232 (set-face-property face win-prop (vector frobbed-face) | |
| 1233 (or (global-locale locale) locale) tag-set)))))) | |
| 428 | 1234 |
| 707 | 1235 ;; WE DEMAND FOUNDRY FROBBING! |
| 1236 | |
| 1237 ;; Family frobbing | |
| 1238 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1239 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan. | |
| 1240 ;; I'm long since flown to Rio, it does you little good to blame me, either. | |
| 872 | 1241 (defun make-face-family (face family &optional locale tags exact-p) |
| 1242 "Set FACE's family to FAMILY in LOCALE, if possible." | |
| 1243 (interactive (list (read-face-name "Set family of which face: ") | |
| 1244 (read-string "Family to set: "))) | |
| 707 | 1245 |
| 872 | 1246 (Face-frob-property face locale tags exact-p |
| 1247 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1248 ;; #### this code is duplicated in make-face-size |
| 872 | 1249 `(lambda (f d) |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1250 ;; keep the dependency on font.el for now |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1251 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1252 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1253 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1254 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1255 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1256 (set-font-family fo ,family) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1257 (font-create-name fo d)))) |
| 872 | 1258 nil)) |
| 707 | 1259 |
| 1260 ;; Style (ie, typographical face) frobbing | |
| 872 | 1261 (defun make-face-bold (face &optional locale tags exact-p) |
| 428 | 1262 "Make FACE bold in LOCALE, if possible. |
| 872 | 1263 This will attempt to make the font bold for window-system locales and will |
| 1264 set the highlight flag for TTY locales. | |
| 1265 | |
| 1266 The actual behavior of this function is somewhat messy, in an attempt to | |
| 1267 get more intuitive behavior in quite a lot of different circumstances. (You | |
| 1268 might view this as indicative of design failures with specifiers, but in | |
| 1269 fact almost all code that attempts to interface to humans and produce | |
| 1270 \"intuitive\" results gets messy, particularly with a system as complicated | |
| 1271 as specifiers, whose complexity results from an attempt to work well in | |
| 1272 many different circumstances.) | |
| 1273 | |
| 1274 The meaning of LOCALE is the same as for `specifier-spec-list', i.e.: | |
| 1275 | |
| 1276 -- If LOCALE is nil, omitted, or `all', this will attempt to \"frob\" all | |
| 1277 font specifications for FACE to make them appear bold (i.e. the | |
| 1278 specifications are replaced with equivalent specifications, where the | |
| 1279 font names have been changed to the closest bold font). | |
| 1280 | |
| 1281 -- If LOCALE is a locale type \(`buffer', `window', etc.), this frobs all | |
| 1282 font specifications for locales of that type. | |
| 1283 | |
| 1284 -- If LOCALE is a particular locale, this frobs all font specifications for | |
| 1285 that locale. | |
| 428 | 1286 |
| 872 | 1287 If TAGS is given, this only processes instantiators whose tag set includes |
| 1288 all tags mentioned in TAGS. In addition, if EXACT-P is non-nil, only | |
| 1289 instantiators whose tag set exactly matches TAGS are processed; otherwise, | |
| 1290 additional tags may be present in the instantiator's tag set. | |
| 1291 | |
| 1292 This function proceeeds in three stages. | |
| 1293 | |
| 1294 STAGE 1: Frob the settings that are already present. | |
| 1295 STAGE 2: (if called for) Ensure that *some* setting exists in the locale | |
| 1296 that was given, finding it in various ways and frobbing it as in | |
| 1297 stage 1. This ensures that there is an actual setting for | |
| 1298 the locale, so you will get the expected buffer-local/frame-local | |
| 1299 behavior -- changes to the global value, to other locales, won't | |
| 1300 affect this locale, (b) the face will actually look bold in | |
| 1301 the locale. | |
| 1137 | 1302 STAGE 3: (if called for) |
| 872 | 1303 |
| 1304 The way the frobbing works depends on the device type -- first on whether | |
| 1305 or not it's TTY, and second, if it's a window-system device type, on which | |
| 1306 particular window-system device type. For locales with a specific device | |
| 1307 type, we do the frobbing in the context of that device type -- this means | |
| 1308 that for TTY device types we set the highlight flag, and for window-system | |
| 1309 device types we modify the font spec according to the rules for font specs | |
| 1310 of that device type. For global locales, we may process both the highlight | |
| 1311 flag and the font specs (depending on the device types compiled into this | |
| 1312 XEmacs). When processing font specs, we check the tag set associated with | |
| 1313 each font spec to see if it's specific to a particular device type; if so, | |
| 1314 we frob it in the context of that type, else we use the type of the current | |
| 1315 device. (A hack, but works well in practice -- and if a new device is | |
| 1316 created, we will automatically frob all the standard fonts to make sure | |
| 1317 they display OK on that device.) | |
| 1318 | |
| 1319 If LOCALE is not a locale type, and both TAGS and EXACT-P are omitted, we | |
| 1320 do further frobbing in an attempt to give more intuitive behavior. | |
| 428 | 1321 |
| 872 | 1322 First, if there are no specifications in LOCALE (if LOCALE is `all', we act |
| 1323 as if it were `global' for this step), we do our utmost to put a | |
| 1324 specification there; otherwise, this function will have no effect. For | |
| 1325 device, frame, or window locales, the face's font is instantiated using the | |
| 1326 locale as a domain, and the resulting font is frobbed and added back as a | |
| 1327 specification for this locale. If LOCALE is `global', we retrieve the | |
| 1328 fallback specs and frob them. If LOCALE is a buffer, things get tricky | |
| 1329 since you can't instantiate a specifier in a buffer domain \(the buffer can | |
| 1330 appear in multiple places, or in different places over time, so this | |
| 1331 operation is not well-defined). We used to signal an error in this case, | |
| 1332 but now we instead try to do something logical so that we work somewhat | |
| 1333 similarly to buffer-local variables. Specifically, we use | |
| 1334 `get-buffer-window' to find a window viewing the buffer, and if there is | |
| 1335 one, use this as a domain to instantiate the font, and frob the resulting | |
| 1336 value. Otherwise, we use the selected window for the same purpose. | |
| 1337 | |
| 1338 Finally, if the frobbing didn't actually make the font look any different | |
| 1339 in whatever domain we instantiated the font in (this happens, for example, | |
| 1340 if your font specification is already bold or has no bold equivalent; note | |
| 1341 that in this step, we use the selected device in place of `global' or `all' | |
| 1342 -- another hack, but works well in practice since there's usually only one | |
| 1343 device), and the font currently looks like the font of the `default' face, | |
| 1344 it is set to inherit from the `bold' face. | |
| 1345 | |
| 1346 NOTE: For the other functions defined below, the identity of these two | |
| 1347 standard faces mentioned in the previous paragraph, and the TTY properties | |
| 1348 that are modified, may be different, and whether the TTY property or | |
| 1349 properties are set or unset may be different. For example, for | |
| 1350 `make-face-unitalic', the last sentence in the previous paragraph would | |
| 1351 read \"... and the font currently looks like the font of the `italic' face, | |
| 1352 it is set to inherit from the `default' face.\", and the second sentence in | |
| 1353 the first paragraph would read \"This will attempt to make the font | |
| 1354 non-italic for window-system locales and will unset the underline flag for | |
| 1355 TTY locales.\" | |
| 1356 | |
| 1357 Here's a table indicating the behavior differences with the different | |
| 1358 functions: | |
| 1359 | |
| 1360 function face1 face2 tty-props tty-val | |
| 1361 ---------------------------------------------------------------------------- | |
| 1362 make-face-bold default bold highlight t | |
| 1363 make-face-italic default italic underline t | |
| 1364 make-face-bold-italic default bold-italic highlight,underline t | |
| 1365 make-face-unbold bold default highlight nil | |
| 1366 make-face-unitalic italic default underline nil | |
| 1367 " | |
| 428 | 1368 (interactive (list (read-face-name "Make which face bold: "))) |
| 872 | 1369 (Face-frob-property face locale tags exact-p |
| 1370 'default 'bold 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1371 '(tty (lambda (f d) t) |
| 872 | 1372 x x-make-font-bold |
| 1373 gtk gtk-make-font-bold | |
| 1374 mswindows mswindows-make-font-bold | |
| 1375 msprinter mswindows-make-font-bold) | |
| 1376 '(([default] . [bold]) | |
| 1377 ([bold] . t) | |
| 1378 ([italic] . [bold-italic]) | |
| 1379 ([bold-italic] . t)))) | |
| 428 | 1380 |
| 872 | 1381 (defun make-face-italic (face &optional locale tags exact-p) |
| 428 | 1382 "Make FACE italic in LOCALE, if possible. |
| 442 | 1383 This will attempt to make the font italic for X/MS Windows locales and |
| 1384 will set the underline flag for TTY locales. See `make-face-bold' for | |
| 1385 the semantics of the LOCALE argument and for more specifics on exactly | |
| 1386 how this function works." | |
| 428 | 1387 (interactive (list (read-face-name "Make which face italic: "))) |
| 872 | 1388 (Face-frob-property face locale tags exact-p |
| 1389 'default 'italic 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1390 '(tty (lambda (f d) t) |
| 872 | 1391 x x-make-font-italic |
| 1392 gtk gtk-make-font-italic | |
| 1393 mswindows mswindows-make-font-italic | |
| 1394 msprinter mswindows-make-font-italic) | |
| 1395 '(([default] . [italic]) | |
| 1396 ([bold] . [bold-italic]) | |
| 1397 ([italic] . t) | |
| 1398 ([bold-italic] . t)))) | |
| 428 | 1399 |
| 872 | 1400 (defun make-face-bold-italic (face &optional locale tags exact-p) |
| 428 | 1401 "Make FACE bold and italic in LOCALE, if possible. |
| 442 | 1402 This will attempt to make the font bold-italic for X/MS Windows |
| 1403 locales and will set the highlight and underline flags for TTY | |
| 1404 locales. See `make-face-bold' for the semantics of the LOCALE | |
| 1405 argument and for more specifics on exactly how this function works." | |
| 428 | 1406 (interactive (list (read-face-name "Make which face bold-italic: "))) |
| 872 | 1407 (Face-frob-property face locale tags exact-p |
| 1408 'default 'bold-italic 'font '(underline highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1409 '(tty (lambda (f d) t) |
| 872 | 1410 x x-make-font-bold-italic |
| 1411 gtk gtk-make-font-bold-italic | |
| 1412 mswindows mswindows-make-font-bold-italic | |
| 1413 msprinter mswindows-make-font-bold-italic) | |
| 1414 '(([default] . [italic]) | |
| 1415 ([bold] . [bold-italic]) | |
| 1416 ([italic] . [bold-italic]) | |
| 1417 ([bold-italic] . t)))) | |
| 428 | 1418 |
| 872 | 1419 |
| 1420 (defun make-face-unbold (face &optional locale tags exact-p) | |
| 428 | 1421 "Make FACE non-bold in LOCALE, if possible. |
| 442 | 1422 This will attempt to make the font non-bold for X/MS Windows locales |
| 1423 and will unset the highlight flag for TTY locales. See | |
| 1424 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1425 specifics on exactly how this function works." | |
| 428 | 1426 (interactive (list (read-face-name "Make which face non-bold: "))) |
| 872 | 1427 (Face-frob-property face locale tags exact-p |
| 1428 'bold 'default 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1429 '(tty (lambda (f d) nil) |
| 872 | 1430 x x-make-font-unbold |
| 1431 gtk gtk-make-font-unbold | |
| 1432 mswindows mswindows-make-font-unbold | |
| 1433 msprinter mswindows-make-font-unbold) | |
| 1434 '(([default] . t) | |
| 1435 ([bold] . [default]) | |
| 1436 ([italic] . t) | |
| 1437 ([bold-italic] . [italic])))) | |
| 428 | 1438 |
| 872 | 1439 (defun make-face-unitalic (face &optional locale tags exact-p) |
| 428 | 1440 "Make FACE non-italic in LOCALE, if possible. |
| 442 | 1441 This will attempt to make the font non-italic for X/MS Windows locales |
| 1442 and will unset the underline flag for TTY locales. See | |
| 1443 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1444 specifics on exactly how this function works." | |
| 428 | 1445 (interactive (list (read-face-name "Make which face non-italic: "))) |
| 872 | 1446 (Face-frob-property face locale tags exact-p |
| 1447 'italic 'default 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1448 '(tty (lambda (f d) nil) |
| 872 | 1449 x x-make-font-unitalic |
| 1450 gtk gtk-make-font-unitalic | |
| 1451 mswindows mswindows-make-font-unitalic | |
| 1452 msprinter mswindows-make-font-unitalic) | |
| 1453 '(([default] . t) | |
| 1454 ([bold] . t) | |
| 1455 ([italic] . [default]) | |
| 1456 ([bold-italic] . [bold])))) | |
| 428 | 1457 |
| 1458 | |
| 707 | 1459 ;; Size frobbing |
| 1460 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1137 | 1461 ;; Jan had a separate helper function |
| 872 | 1462 (defun make-face-size (face size &optional locale tags exact-p) |
| 1463 "Adjust FACE to SIZE in LOCALE, if possible." | |
| 1464 (interactive (list (read-face-name "Set size of which face: ") | |
| 1465 (read-number "Size to set: " t 10))) | |
| 1466 (Face-frob-property face locale tags exact-p | |
| 1467 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1468 ;; #### this code is duplicated in make-face-family |
| 872 | 1469 `(lambda (f d) |
| 1470 ;; keep the dependency on font.el for now | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1471 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1472 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1473 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1474 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1475 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1476 (set-font-size fo ,size) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1477 (font-create-name fo d)))) |
| 872 | 1478 nil)) |
| 707 | 1479 |
| 428 | 1480 ;; Why do the following two functions lose so badly in so many |
| 1481 ;; circumstances? | |
| 1482 | |
| 872 | 1483 (defun make-face-smaller (face &optional locale tags exact-p) |
| 428 | 1484 "Make the font of FACE be smaller, if possible. |
| 1485 LOCALE works as in `make-face-bold' et al., but the ``inheriting- | |
| 1486 from-the-bold-face'' operations described there are not done | |
| 1487 because they don't make sense in this context." | |
| 1488 (interactive (list (read-face-name "Shrink which face: "))) | |
| 872 | 1489 (Face-frob-property face locale tags exact-p |
| 1490 nil nil 'font nil | |
| 1491 '(x x-find-smaller-font | |
| 1492 gtk gtk-find-smaller-font | |
| 1493 mswindows mswindows-find-smaller-font | |
| 1494 msprinter mswindows-find-smaller-font) | |
| 1495 nil)) | |
| 428 | 1496 |
| 872 | 1497 (defun make-face-larger (face &optional locale tags exact-p) |
| 428 | 1498 "Make the font of FACE be larger, if possible. |
| 1499 See `make-face-smaller' for the semantics of the LOCALE argument." | |
| 1500 (interactive (list (read-face-name "Enlarge which face: "))) | |
| 872 | 1501 (Face-frob-property face locale tags exact-p |
| 1502 nil nil 'font nil | |
| 1503 '(x x-find-larger-font | |
| 1504 gtk gtk-find-larger-font | |
| 1505 mswindows mswindows-find-larger-font | |
| 1506 msprinter mswindows-find-larger-font) | |
| 1507 nil)) | |
| 428 | 1508 |
| 1509 (defun invert-face (face &optional locale) | |
| 1510 "Swap the foreground and background colors of the face." | |
| 1511 (interactive (list (read-face-name "Invert face: "))) | |
| 1512 (if (valid-specifier-domain-p locale) | |
| 1513 (let ((foreface (face-foreground-instance face locale))) | |
| 1514 (set-face-foreground face (face-background-instance face locale) | |
| 1515 locale) | |
| 1516 (set-face-background face foreface locale)) | |
| 1517 (let ((forespec (copy-specifier (face-foreground face) nil locale))) | |
| 1518 (copy-specifier (face-background face) (face-foreground face) locale) | |
| 1519 (copy-specifier forespec (face-background face) locale)))) | |
| 1520 | |
| 1521 | |
| 1522 ;;; Convenience functions | |
| 1523 | |
| 1524 (defun face-ascent (face &optional domain charset) | |
| 1525 "Return the ascent of FACE in DOMAIN. | |
| 1526 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1527 (font-ascent (face-font face) domain charset)) | |
| 1528 | |
| 1529 (defun face-descent (face &optional domain charset) | |
| 1530 "Return the descent of FACE in DOMAIN. | |
| 1531 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1532 (font-descent (face-font face) domain charset)) | |
| 1533 | |
| 1534 (defun face-width (face &optional domain charset) | |
| 1535 "Return the width of FACE in DOMAIN. | |
| 1536 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1537 (font-width (face-font face) domain charset)) | |
| 1538 | |
| 1539 (defun face-height (face &optional domain charset) | |
| 1540 "Return the height of FACE in DOMAIN. | |
| 1541 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1542 (+ (face-ascent face domain charset) (face-descent face domain charset))) | |
| 1543 | |
| 1544 (defun face-proportional-p (face &optional domain charset) | |
| 1545 "Return t if FACE is proportional in DOMAIN. | |
| 1546 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1547 (font-proportional-p (face-font face) domain charset)) | |
| 1548 | |
| 1549 | |
| 1550 ;; Functions that used to be in cus-face.el, but logically go here. | |
| 1551 | |
| 1552 (defcustom frame-background-mode nil | |
| 1553 "*The brightness of the background. | |
| 1554 Set this to the symbol dark if your background color is dark, light if | |
| 1555 your background is light, or nil (default) if you want Emacs to | |
| 1556 examine the brightness for you." | |
| 1557 :group 'faces | |
| 1558 :type '(choice (choice-item dark) | |
| 1559 (choice-item light) | |
| 1560 (choice-item :tag "Auto" nil))) | |
| 1561 | |
| 1562 ;; The old variable that many people still have in .emacs files. | |
| 1563 (define-obsolete-variable-alias 'custom-background-mode | |
| 1564 'frame-background-mode) | |
| 1565 | |
| 1566 (defun get-frame-background-mode (frame) | |
| 1567 "Detect background mode for FRAME." | |
| 1568 (let* ((color-instance (face-background-instance 'default frame)) | |
| 1569 (mode (condition-case nil | |
| 1570 (if (< (apply '+ (color-instance-rgb-components | |
| 1571 color-instance)) 65536) | |
| 1572 'dark 'light) | |
| 872 | 1573 ;; Here, we get an error on a TTY (Return value from |
| 1574 ;; color-instance-rgb-components is nil), and on the | |
| 1575 ;; initial stream device (Return value from | |
| 1576 ;; face-background-instance is nil). As we don't have a | |
| 1577 ;; good way of detecting whether a TTY is light or dark, | |
| 1578 ;; we'll guess it's dark. | |
| 428 | 1579 (error 'dark)))) |
| 1580 (set-frame-property frame 'background-mode mode) | |
| 1581 mode)) | |
| 1582 | |
| 1583 (defun extract-custom-frame-properties (frame) | |
| 1584 "Return a plist with the frame properties of FRAME used by custom." | |
| 1585 (list 'type (or (frame-property frame 'display-type) | |
| 1586 (device-type (frame-device frame))) | |
| 1587 'class (device-class (frame-device frame)) | |
| 1588 'background (or frame-background-mode | |
| 1589 (frame-property frame 'background-mode) | |
| 1590 (get-frame-background-mode frame)))) | |
| 1591 | |
| 1592 (defcustom init-face-from-resources t | |
| 1593 "If non nil, attempt to initialize faces from the resource database." | |
| 1594 :group 'faces | |
| 1595 :type 'boolean) | |
| 1596 | |
| 1597 ;; Old name, used by custom. Also, FSFmacs name. | |
| 1598 (defvaralias 'initialize-face-resources 'init-face-from-resources) | |
| 1599 | |
| 1600 ;; Make sure all custom setting are added with this tag so we can | |
| 1601 ;; identify-them | |
| 1602 (define-specifier-tag 'custom) | |
| 1603 | |
| 1604 (defun face-spec-set (face spec &optional frame tags) | |
| 1605 "Set FACE's face attributes according to the first matching entry in SPEC. | |
| 1606 If optional FRAME is non-nil, set it for that frame only. | |
| 1607 If it is nil, then apply SPEC to each frame individually. | |
| 1608 See `defface' for information about SPEC." | |
| 1609 (if frame | |
| 1610 (progn | |
| 1611 (reset-face face frame tags) | |
| 1612 (face-display-set face spec frame tags) | |
| 1613 (init-face-from-resources face frame)) | |
| 1614 (let ((frames (relevant-custom-frames))) | |
| 1615 (reset-face face nil tags) | |
| 1616 ;; This should not be needed. We only remove our own specifiers | |
| 1617 ;; (if (and (eq 'default face) (featurep 'x)) | |
| 1618 ;; (x-init-global-faces)) | |
| 1619 (face-display-set face spec nil tags) | |
| 1620 (while frames | |
| 1621 (face-display-set face spec (car frames) tags) | |
| 1622 (pop frames)) | |
| 1623 (init-face-from-resources face)))) | |
| 1624 | |
| 1625 (defun face-display-set (face spec &optional frame tags) | |
| 1626 "Set FACE to the attributes to the first matching entry in SPEC. | |
| 1627 Iff optional FRAME is non-nil, set it for that frame only. | |
| 1628 See `defface' for information about SPEC." | |
| 1629 (while spec | |
| 1630 (let ((display (caar spec)) | |
| 1631 (atts (cadar spec))) | |
| 1632 (pop spec) | |
| 1633 (when (face-spec-set-match-display display frame) | |
| 1634 ;; Avoid creating frame local duplicates of the global face. | |
| 1635 (unless (and frame (eq display (get face 'custom-face-display))) | |
| 1636 (apply 'face-custom-attributes-set face frame tags atts)) | |
| 1637 (unless frame | |
| 1638 (put face 'custom-face-display display)) | |
| 1639 (setq spec nil))))) | |
| 1640 | |
| 1641 (defvar default-custom-frame-properties nil | |
| 1642 "The frame properties used for the global faces. | |
| 442 | 1643 Frames not matching these properties should have frame local faces. |
| 428 | 1644 The value should be nil, if uninitialized, or a plist otherwise. |
| 1645 See `defface' for a list of valid keys and values for the plist.") | |
| 1646 | |
| 1647 (defun get-custom-frame-properties (&optional frame) | |
| 1648 "Return a plist with the frame properties of FRAME used by custom. | |
| 1649 If FRAME is nil, return the default frame properties." | |
| 1650 (cond (frame | |
| 1651 ;; Try to get from cache. | |
| 1652 (let ((cache (frame-property frame 'custom-properties))) | |
| 1653 (unless cache | |
| 1654 ;; Oh well, get it then. | |
| 1655 (setq cache (extract-custom-frame-properties frame)) | |
| 1656 ;; and cache it... | |
| 1657 (set-frame-property frame 'custom-properties cache)) | |
| 1658 cache)) | |
| 1659 (default-custom-frame-properties) | |
| 1660 (t | |
| 1661 (setq default-custom-frame-properties | |
| 1662 (extract-custom-frame-properties (selected-frame)))))) | |
| 1663 | |
| 1664 (defun face-spec-update-all-matching (spec display plist) | |
| 1665 "Update all entries in the face spec that could match display to | |
| 444 | 1666 have the entries from the new plist and return the new spec." |
| 428 | 1667 (mapcar |
| 1668 (lambda (e) | |
| 1669 (let ((entries (car e)) | |
| 1670 (options (cadr e)) | |
| 1671 (match t) | |
| 1672 dplist | |
| 1673 (new-options plist) | |
| 1674 ) | |
| 1675 (unless (eq display t) | |
| 1676 (mapc (lambda (arg) | |
| 1677 (setq dplist (plist-put dplist (car arg) (cadr arg)))) | |
| 1678 display)) | |
| 1679 (unless (eq entries t) | |
| 1680 (mapc (lambda (arg) | |
| 1681 (setq match (and match (eq (cadr arg) | |
| 1682 (plist-get | |
| 1683 dplist (car arg) | |
| 1684 (cadr arg)))))) | |
| 1685 entries)) | |
| 1686 (if (not match) | |
| 1687 e | |
| 1688 (while new-options | |
| 1689 (setq options | |
| 1690 (plist-put options (car new-options) (cadr new-options))) | |
| 1691 (setq new-options (cddr new-options))) | |
| 1692 (list entries options)))) | |
| 1693 (copy-sequence spec))) | |
| 444 | 1694 |
| 1695 | |
| 428 | 1696 |
| 1697 (defun face-spec-set-match-display (display &optional frame) | |
| 1698 "Return non-nil if DISPLAY matches FRAME. | |
| 1699 DISPLAY is part of a spec such as can be used in `defface'. | |
| 1700 If FRAME is nil or omitted, the selected frame is used." | |
| 1701 (if (eq display t) | |
| 1702 t | |
| 1703 (let* ((props (get-custom-frame-properties frame)) | |
| 1704 (type (plist-get props 'type)) | |
| 1705 (class (plist-get props 'class)) | |
| 1706 (background (plist-get props 'background)) | |
| 1707 (match t) | |
| 1708 (entries display) | |
| 1709 entry req options) | |
| 1710 (while (and entries match) | |
| 1711 (setq entry (car entries) | |
| 1712 entries (cdr entries) | |
| 1713 req (car entry) | |
| 1714 options (cdr entry) | |
| 1715 match (case req | |
| 1716 (type (memq type options)) | |
| 1717 (class (memq class options)) | |
| 1718 (background (memq background options)) | |
| 1719 (t (warn "Unknown req `%S' with options `%S'" | |
| 1720 req options) | |
| 1721 nil)))) | |
| 1722 match))) | |
| 1723 | |
| 1724 (defun relevant-custom-frames () | |
| 1725 "List of frames whose custom properties differ from the default." | |
| 1726 (let ((relevant nil) | |
| 1727 (default (get-custom-frame-properties)) | |
| 1728 (frames (frame-list)) | |
| 1729 frame) | |
| 1730 (while frames | |
| 1731 (setq frame (car frames) | |
| 1732 frames (cdr frames)) | |
| 1733 (unless (equal default (get-custom-frame-properties frame)) | |
| 1734 (push frame relevant))) | |
| 1735 relevant)) | |
| 1736 | |
| 1737 (defun initialize-custom-faces (&optional frame) | |
| 1738 "Initialize all custom faces for FRAME. | |
| 1739 If FRAME is nil or omitted, initialize them for all frames." | |
| 1740 (mapc (lambda (symbol) | |
| 1741 (let ((spec (or (get symbol 'saved-face) | |
| 1742 (get symbol 'face-defface-spec)))) | |
| 1743 (when spec | |
| 1744 ;; No need to init-face-from-resources -- code in | |
| 1745 ;; `init-frame-faces' does it already. | |
| 1746 (face-display-set symbol spec frame)))) | |
| 1747 (face-list))) | |
| 1748 | |
| 1749 (defun custom-initialize-frame (frame) | |
| 1750 "Initialize frame-local custom faces for FRAME if necessary." | |
| 1751 (unless (equal (get-custom-frame-properties) | |
| 1752 (get-custom-frame-properties frame)) | |
| 1753 (initialize-custom-faces frame))) | |
| 1754 | |
| 440 | 1755 (defun startup-initialize-custom-faces () |
| 1756 "Reset faces created by defface. Only called at startup. | |
| 1757 Don't use this function in your program." | |
| 1758 (when default-custom-frame-properties | |
| 1759 ;; Reset default value to the actual frame, not stream. | |
| 1760 (setq default-custom-frame-properties | |
| 1761 (extract-custom-frame-properties (selected-frame))) | |
| 1762 ;; like initialize-custom-faces but removes property first. | |
| 1763 (mapc (lambda (symbol) | |
| 1764 (let ((spec (or (get symbol 'saved-face) | |
| 1765 (get symbol 'face-defface-spec)))) | |
| 1766 (when spec | |
| 1767 ;; Reset faces created during auto-autoloads loading. | |
| 1768 (reset-face symbol) | |
| 1769 ;; And set it according to the spec. | |
| 1770 (face-display-set symbol spec nil)))) | |
| 1771 (face-list)))) | |
| 1772 | |
| 428 | 1773 |
| 1774 (defun make-empty-face (name &optional doc-string temporary) | |
| 1775 "Like `make-face', but doesn't query the resource database." | |
| 1776 (let ((init-face-from-resources nil)) | |
| 1777 (make-face name doc-string temporary))) | |
| 1778 | |
| 1779 (defun init-face-from-resources (face &optional locale) | |
| 1780 "Initialize FACE from the resource database. | |
| 3027 | 1781 If LOCALE is specified, it should be a frame, device, or `global', and |
| 428 | 1782 the face will be resourced over that locale. Otherwise, the face will |
| 1783 be resourced over all possible locales (i.e. all frames, all devices, | |
| 3027 | 1784 and `global')." |
| 428 | 1785 (cond ((null init-face-from-resources) |
| 1786 ;; Do nothing. | |
| 1787 ) | |
| 1788 ((not locale) | |
| 1789 ;; Global, set for all frames. | |
| 1790 (progn | |
| 1791 (init-face-from-resources face 'global) | |
| 1792 (let ((devices (device-list))) | |
| 1793 (while devices | |
| 1794 (init-face-from-resources face (car devices)) | |
| 1795 (setq devices (cdr devices)))) | |
| 1796 (let ((frames (frame-list))) | |
| 1797 (while frames | |
| 1798 (init-face-from-resources face (car frames)) | |
| 1799 (setq frames (cdr frames)))))) | |
| 1800 (t | |
| 1801 ;; Specific. | |
| 1802 (let ((devtype (cond ((devicep locale) (device-type locale)) | |
| 1803 ((framep locale) (frame-type locale)) | |
| 1804 (t nil)))) | |
| 1805 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) | |
| 502 | 1806 (declare-fboundp (x-init-face-from-resources face locale))) |
| 428 | 1807 ((or (not devtype) (eq 'tty devtype)) |
| 1808 ;; Nothing to do for TTYs? | |
| 1809 )))))) | |
| 1810 | |
| 1811 (defun init-device-faces (device) | |
| 1812 ;; First, add any device-local face resources. | |
| 1813 (when init-face-from-resources | |
| 1814 (loop for face in (face-list) do | |
| 1815 (init-face-from-resources face device)) | |
| 1816 ;; Then do any device-specific initialization. | |
| 1817 (cond ((eq 'x (device-type device)) | |
| 502 | 1818 (declare-fboundp (x-init-device-faces device))) |
| 462 | 1819 ((eq 'gtk (device-type device)) |
| 502 | 1820 (declare-fboundp (gtk-init-device-faces device))) |
| 428 | 1821 ((eq 'mswindows (device-type device)) |
| 502 | 1822 (declare-fboundp (mswindows-init-device-faces device))) |
| 428 | 1823 ;; Nothing to do for TTYs? |
| 1824 ) | |
| 1825 (or (eq 'stream (device-type device)) | |
| 1826 (init-other-random-faces device)))) | |
| 1827 | |
| 1828 (defun init-frame-faces (frame) | |
| 1829 (when init-face-from-resources | |
| 1830 ;; First, add any frame-local face resources. | |
| 1831 (loop for face in (face-list) do | |
| 1832 (init-face-from-resources face frame)) | |
| 1833 ;; Then do any frame-specific initialization. | |
| 1834 (cond ((eq 'x (frame-type frame)) | |
| 502 | 1835 (declare-fboundp (x-init-frame-faces frame))) |
| 462 | 1836 ((eq 'gtk (frame-type frame)) |
| 502 | 1837 (declare-fboundp (gtk-init-frame-faces frame))) |
| 428 | 1838 ((eq 'mswindows (frame-type frame)) |
| 502 | 1839 (declare-fboundp (mswindows-init-frame-faces frame))) |
| 428 | 1840 ;; Is there anything which should be done for TTY's? |
| 1841 ))) | |
| 1842 | |
| 872 | 1843 ;; Called when the first device created. |
| 428 | 1844 |
| 872 | 1845 (defun init-global-faces (device) |
| 1846 (let ((Face-frob-property-device-considered-current device)) | |
| 1847 ;; Look for global face resources. | |
| 1848 (loop for face in (face-list) do | |
| 1849 (init-face-from-resources face 'global)) | |
| 1850 ;; Further frobbing. | |
| 1851 (and (featurep 'x) (declare-fboundp (x-init-global-faces))) | |
| 1852 (and (featurep 'gtk) (declare-fboundp (gtk-init-global-faces))) | |
| 1853 (and (featurep 'mswindows) (declare-fboundp (mswindows-init-global-faces))) | |
| 462 | 1854 |
| 872 | 1855 ;; for bold and the like, make the global specification be bold etc. |
| 1856 ;; if the user didn't already specify a value. These will also be | |
| 1857 ;; frobbed further in init-other-random-faces. | |
| 1858 (unless (face-font 'bold 'global) | |
| 1859 (make-face-bold 'bold 'global)) | |
| 1860 ;; | |
| 1861 (unless (face-font 'italic 'global) | |
| 1862 (make-face-italic 'italic 'global)) | |
| 1863 ;; | |
| 428 | 1864 (unless (face-font 'bold-italic 'global) |
| 872 | 1865 (make-face-bold-italic 'bold-italic 'global) |
| 1866 (unless (face-font 'bold-italic 'global) | |
| 1867 (copy-face 'bold 'bold-italic) | |
| 1868 (make-face-italic 'bold-italic))) | |
| 428 | 1869 |
| 872 | 1870 (when (face-equal 'bold 'bold-italic device) |
| 1871 (copy-face 'italic 'bold-italic) | |
| 1872 (make-face-bold 'bold-italic)))) | |
| 428 | 1873 |
| 1874 | |
| 1875 ;; These warnings are there for a reason. Just specify your fonts | |
| 1876 ;; correctly. Deal with it. Additionally, one can use | |
| 1877 ;; `log-warning-minimum-level' instead of this. | |
| 1878 ;(defvar inhibit-font-complaints nil | |
| 1879 ; "Whether to suppress complaints about incomplete sets of fonts.") | |
| 1880 | |
| 1881 (defun face-complain-about-font (face device) | |
| 1882 (if (symbolp face) (setq face (symbol-name face))) | |
| 1883 ;; (if (not inhibit-font-complaints) | |
| 707 | 1884 ;; complaining for printers is generally annoying. |
| 1885 (unless (device-printer-p device) | |
| 1886 (display-warning | |
| 1887 'font | |
| 1888 (let ((default-name (face-font-name 'default device))) | |
| 1889 (format "%s: couldn't deduce %s %s version of the font | |
| 428 | 1890 %S. |
| 1891 | |
| 1892 Please specify X resources to make the %s face | |
| 1893 visually distinguishable from the default face. | |
| 1894 For example, you could add one of the following to $HOME/Emacs: | |
| 1895 | |
| 2703 | 1896 XEmacs.%s.attributeFont: -dt-*-medium-i-* |
| 428 | 1897 or |
| 2703 | 1898 XEmacs.%s.attributeForeground: hotpink\n" |
| 707 | 1899 invocation-name |
| 1900 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") | |
| 1901 face | |
| 1902 default-name | |
| 1903 face | |
| 1904 face | |
| 1905 face | |
| 1906 ))))) | |
| 428 | 1907 |
| 1908 | |
| 1909 ;; #### This is quite a mess. We should use the custom mechanism for | |
| 1910 ;; most of this stuff. Currently we don't do it, because Custom | |
| 1911 ;; doesn't use specifiers (yet.) FSF does it the Right Way. | |
| 1912 | |
| 1913 ;; For instance, the definition of `bold' should be something like | |
| 1914 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should | |
| 1915 ;; make sure that everything works properly. | |
| 1916 | |
| 1917 (defun init-other-random-faces (device) | |
| 1918 "Initialize the colors and fonts of the bold, italic, bold-italic, | |
| 1919 zmacs-region, list-mode-item-selected, highlight, primary-selection, | |
| 1920 secondary-selection, and isearch faces when each device is created. If | |
| 1921 you want to add code to do stuff like this, use the create-device-hook." | |
| 1922 | |
| 1923 ;; try to make 'bold look different from the default on this device. | |
| 1924 ;; If that doesn't work at all, then issue a warning. | |
| 1925 (unless (face-differs-from-default-p 'bold device) | |
| 1926 (make-face-bold 'bold device) | |
| 1927 (unless (face-differs-from-default-p 'bold device) | |
| 1928 (make-face-unbold 'bold device) | |
| 1929 (unless (face-differs-from-default-p 'bold device) | |
| 1930 ;; the luser specified one of the bogus font names | |
| 1931 (face-complain-about-font 'bold device)))) | |
| 1932 | |
| 1933 ;; Similar for italic. | |
| 1934 ;; It's unreasonable to expect to be able to make a font italic all | |
| 1935 ;; the time. For many languages, italic is an alien concept. | |
| 1936 ;; Basically, because italic is not a globally meaningful concept, | |
| 440 | 1937 ;; the use of the italic face should really be obsoleted. |
| 428 | 1938 |
| 1939 ;; I disagree with above. In many languages, the concept of capital | |
| 1940 ;; letters is just as alien, and yet we use them. Italic is here to | |
| 1941 ;; stay. -hniksic | |
| 1942 | |
| 1943 ;; In a Solaris Japanese environment, there just aren't any italic | |
| 1944 ;; fonts - period. CDE recognizes this reality, and fonts | |
| 1945 ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come | |
| 1946 ;; in italic versions. So we first try to make the font bold before | |
| 1947 ;; complaining. | |
| 1948 (unless (face-differs-from-default-p 'italic device) | |
| 1949 (make-face-italic 'italic device) | |
| 1950 (unless (face-differs-from-default-p 'italic device) | |
| 1951 (make-face-bold 'italic device) | |
| 1952 (unless (face-differs-from-default-p 'italic device) | |
| 1953 (face-complain-about-font 'italic device)))) | |
| 1954 | |
| 1955 ;; similar for bold-italic. | |
| 1956 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1957 (make-face-bold-italic 'bold-italic device) | |
| 1958 ;; if we couldn't get a bold-italic version, try just bold. | |
| 1959 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1960 (make-face-bold 'bold-italic device) | |
| 1961 ;; if we couldn't get bold or bold-italic, then that's probably because | |
| 1962 ;; the default font is bold, so make the `bold-italic' face be unbold. | |
| 1963 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1964 (make-face-unbold 'bold-italic device) | |
| 1965 (make-face-italic 'bold-italic device) | |
| 1966 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1967 ;; if that didn't work, try plain italic | |
| 1968 ;; (can this ever happen? what the hell.) | |
| 1969 (make-face-italic 'bold-italic device) | |
| 1970 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1971 ;; then bitch and moan. | |
| 1972 (face-complain-about-font 'bold-italic device)))))) | |
| 1973 | |
| 1974 ;; Set the text-cursor colors unless already specified. | |
| 1975 (when (and (not (eq 'tty (device-type device))) | |
| 1976 (not (face-background 'text-cursor 'global)) | |
| 1977 (face-property-equal 'text-cursor 'default 'background device)) | |
| 1978 (set-face-background 'text-cursor [default foreground] 'global | |
| 1979 nil 'append)) | |
| 1980 (when (and (not (eq 'tty (device-type device))) | |
| 1981 (not (face-foreground 'text-cursor 'global)) | |
| 1982 (face-property-equal 'text-cursor 'default 'foreground device)) | |
| 1983 (set-face-foreground 'text-cursor [default background] 'global | |
| 1984 nil 'append)) | |
|
4741
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1985 |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1986 ;; The faces buffers-tab, modeline-mousable and modeline-buffer-id all |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1987 ;; inherit directly from modeline; they require that modeline's details be |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1988 ;; specified, that it not use fallbacks, otherwise *they* use the general |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1989 ;; fallback of the default face instead, which clashes with the gui |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1990 ;; element faces. So take the modeline face information from its |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1991 ;; fallbacks, themselves ultimately set up in faces.c: |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1992 (loop |
|
5080
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
1993 for face-property in '(foreground background |
|
5502045ec510
The background-placement face property.
Didier Verna <didier@lrde.epita.fr>
parents:
4783
diff
changeset
|
1994 background-pixmap background-placement) |
|
4741
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1995 do (when (and (setq face-property (face-property 'modeline face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1996 (null (specifier-instance face-property device nil t)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1997 (specifier-instance face-property device)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1998 (set-specifier face-property |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1999 (or (specifier-specs (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2000 face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2001 ;; This will error at startup if the |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2002 ;; corresponding C fallback doesn't exist, |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2003 ;; which is well and good. |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2004 (specifier-fallback (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2005 face-property)))))) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
2006 nil) |
| 428 | 2007 |
| 442 | 2008 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle |
| 2009 ;; Jones and Hrvoje Niksic. | |
| 428 | 2010 (defun set-face-stipple (face pixmap &optional frame) |
| 2011 "Change the stipple pixmap of FACE to PIXMAP. | |
| 2012 This is an Emacs compatibility function; consider using | |
| 2013 set-face-background-pixmap instead. | |
| 2014 | |
| 2015 PIXMAP should be a string, the name of a file of pixmap data. | |
| 442 | 2016 The directories listed in the variables `x-bitmap-file-path' and |
| 2017 `mswindows-bitmap-file-path' under X and MS Windows respectively | |
| 2018 are searched. | |
| 428 | 2019 |
| 2020 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT | |
| 2021 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is | |
| 2022 a string, containing the raw bits of the bitmap. XBM data is | |
| 2023 expected in this case, other types of image data will not work. | |
| 2024 | |
| 2025 If the optional FRAME argument is provided, change only | |
| 2026 in that frame; otherwise change each frame." | |
| 2027 (while (not (find-face face)) | |
| 446 | 2028 (setq face (wrong-type-argument 'facep face))) |
| 502 | 2029 (let ((bitmap-path |
| 2030 (ecase (console-type) | |
| 2031 (x (declare-boundp x-bitmap-file-path)) | |
| 2032 (mswindows (declare-boundp mswindows-bitmap-file-path)))) | |
| 442 | 2033 instantiator) |
| 2034 (while | |
| 2035 (null | |
| 2036 (setq instantiator | |
| 2037 (cond ((stringp pixmap) | |
| 2038 (let ((file (if (file-name-absolute-p pixmap) | |
| 2039 pixmap | |
| 2040 (locate-file pixmap bitmap-path | |
| 2041 '(".xbm" ""))))) | |
| 2042 (and file | |
| 2043 `[xbm :file ,file]))) | |
| 2044 ((and (listp pixmap) (= (length pixmap) 3)) | |
| 2045 `[xbm :data ,pixmap]) | |
| 2046 (t nil)))) | |
| 2047 ;; We're signaling a continuable error; let's make sure the | |
| 2048 ;; function `stipple-pixmap-p' at least exists. | |
| 2049 (flet ((stipple-pixmap-p (pixmap) | |
| 2050 (or (stringp pixmap) | |
| 2051 (and (listp pixmap) (= (length pixmap) 3))))) | |
| 2052 (setq pixmap (signal 'wrong-type-argument | |
| 2053 (list 'stipple-pixmap-p pixmap))))) | |
| 446 | 2054 (check-type frame (or null frame)) |
| 442 | 2055 (set-face-background-pixmap face instantiator frame))) |
| 428 | 2056 |
| 2057 | |
| 2058 ;; Create the remaining standard faces now. This way, packages that we dump | |
| 2059 ;; can reference these faces as parents. | |
| 2060 ;; | |
| 2061 ;; The default, modeline, left-margin, right-margin, text-cursor, | |
| 2062 ;; and pointer faces are created in C. | |
| 2063 | |
| 2064 (make-face 'bold "Bold text.") | |
| 2065 (make-face 'italic "Italic text.") | |
| 2066 (make-face 'bold-italic "Bold-italic text.") | |
| 2067 (make-face 'underline "Underlined text.") | |
| 2068 (or (face-differs-from-default-p 'underline) | |
| 2069 (set-face-underline-p 'underline t 'global '(default))) | |
| 735 | 2070 (make-face 'zmacs-region "Used on highlighted region between point and mark.") |
| 428 | 2071 (make-face 'isearch "Used on region matched by isearch.") |
| 2072 (make-face 'isearch-secondary "Face to use for highlighting all matches.") | |
| 2073 (make-face 'list-mode-item-selected | |
| 2074 "Face for the selected list item in list-mode.") | |
| 2075 (make-face 'highlight "Highlight face.") | |
| 2076 (make-face 'primary-selection "Primary selection face.") | |
| 2077 (make-face 'secondary-selection "Secondary selection face.") | |
| 2078 | |
| 2079 ;; Several useful color faces. | |
| 2080 (dolist (color '(red green blue yellow)) | |
| 2081 (make-face color (concat (symbol-name color) " text.")) | |
| 2082 (set-face-foreground color (symbol-name color) nil 'color)) | |
| 2083 | |
| 2084 ;; Make some useful faces. This happens very early, before creating | |
| 2085 ;; the first non-stream device. | |
| 2086 | |
| 2087 (set-face-background 'text-cursor | |
| 711 | 2088 '(((win default) . "Red3")) |
| 428 | 2089 'global) |
| 2090 | |
| 2091 ;; some older X servers don't recognize "darkseagreen2" | |
| 2092 (set-face-background 'highlight | |
| 711 | 2093 '(((win default color) . "darkseagreen2") |
| 2094 ((win default color) . "green") | |
| 2095 ((win default grayscale) . "gray53")) | |
| 428 | 2096 'global) |
| 2097 (set-face-background-pixmap 'highlight | |
| 711 | 2098 '(((win default mono) . "gray1")) |
| 428 | 2099 'global) |
| 2100 | |
| 2101 (set-face-background 'zmacs-region | |
| 711 | 2102 '(((win default color) . "gray65") |
| 2103 ((win default grayscale) . "gray65")) | |
| 428 | 2104 'global) |
| 2105 (set-face-background-pixmap 'zmacs-region | |
| 711 | 2106 '(((win default mono) . "gray3")) |
| 428 | 2107 'global) |
| 2108 | |
| 2109 (set-face-background 'list-mode-item-selected | |
| 711 | 2110 '(((win default color) . "gray68") |
| 2111 ((win default grayscale) . "gray68") | |
| 2112 ((win default mono) . [default foreground])) | |
| 428 | 2113 'global) |
| 2114 (set-face-foreground 'list-mode-item-selected | |
| 711 | 2115 '(((win default mono) . [default background])) |
| 428 | 2116 'global) |
| 2117 | |
| 2118 (set-face-background 'primary-selection | |
| 711 | 2119 '(((win default color) . "gray65") |
| 2120 ((win default grayscale) . "gray65")) | |
| 428 | 2121 'global) |
| 2122 (set-face-background-pixmap 'primary-selection | |
| 711 | 2123 '(((win default mono) . "gray3")) |
| 428 | 2124 'global) |
| 2125 | |
| 2126 (set-face-background 'secondary-selection | |
| 711 | 2127 '(((win default color) . "paleturquoise") |
| 2128 ((win default color) . "green") | |
| 2129 ((win default grayscale) . "gray53")) | |
| 428 | 2130 'global) |
| 2131 (set-face-background-pixmap 'secondary-selection | |
| 711 | 2132 '(((win default mono) . "gray1")) |
| 428 | 2133 'global) |
| 2134 | |
| 2135 (set-face-background 'isearch | |
| 711 | 2136 '(((win default color) . "paleturquoise") |
| 2137 ((win default color) . "green")) | |
| 428 | 2138 'global) |
| 2139 | |
| 2140 ;; #### This should really, I mean *really*, be converted to some form | |
| 2141 ;; of `defface' one day. | |
| 2142 (set-face-foreground 'isearch-secondary | |
| 711 | 2143 '(((win default color) . "red3")) |
| 428 | 2144 'global) |
| 2145 | |
| 2146 ;; Define some logical color names to be used when reading the pixmap files. | |
| 4222 | 2147 (and-boundp |
| 2148 'xpm-color-symbols | |
| 2149 (featurep 'xpm) | |
| 2150 (setq xpm-color-symbols | |
| 2151 (list | |
| 2152 '("foreground" (face-foreground 'default)) | |
| 2153 '("background" (face-background 'default)) | |
|
4676
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2154 `("backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2155 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2156 '(or (x-get-resource "backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2157 "BackgroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2158 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2159 (face-background 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2160 '(face-background 'toolbar))) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2161 `("foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2162 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2163 '(or (x-get-resource "foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2164 "ForegroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2165 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2166 (face-foreground 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2167 '(face-foreground 'toolbar)))))) |
| 428 | 2168 |
| 2169 (when (featurep 'tty) | |
| 2170 (set-face-highlight-p 'bold t 'global '(default tty)) | |
| 2171 (set-face-underline-p 'italic t 'global '(default tty)) | |
| 2172 (set-face-highlight-p 'bold-italic t 'global '(default tty)) | |
| 2173 (set-face-underline-p 'bold-italic t 'global '(default tty)) | |
| 2174 (set-face-highlight-p 'highlight t 'global '(default tty)) | |
| 2175 (set-face-reverse-p 'text-cursor t 'global '(default tty)) | |
| 2176 (set-face-reverse-p 'modeline t 'global '(default tty)) | |
| 2177 (set-face-reverse-p 'zmacs-region t 'global '(default tty)) | |
| 2178 (set-face-reverse-p 'primary-selection t 'global '(default tty)) | |
| 2179 (set-face-underline-p 'secondary-selection t 'global '(default tty)) | |
| 2180 (set-face-reverse-p 'list-mode-item-selected t 'global '(default tty)) | |
| 2181 (set-face-reverse-p 'isearch t 'global '(default tty)) | |
| 2182 ) | |
| 2183 | |
| 2184 ;;; faces.el ends here |