Mercurial > hg > xemacs-beta
comparison lisp/prim/faces.el @ 197:acd284d43ca1 r20-3b25
Import from CVS: tag r20-3b25
author | cvs |
---|---|
date | Mon, 13 Aug 2007 10:00:02 +0200 |
parents | f53b5ca2e663 |
children | eb5470882647 |
comparison
equal
deleted
inserted
replaced
196:58e0786448ca | 197:acd284d43ca1 |
---|---|
344 (remprop (get-face face) property) | 344 (remprop (get-face face) property) |
345 (convert-face-property-into-specifier face property) | 345 (convert-face-property-into-specifier face property) |
346 (remove-specifier (face-property face property) locale tag-set | 346 (remove-specifier (face-property face property) locale tag-set |
347 exact-p)))) | 347 exact-p)))) |
348 | 348 |
349 (defun reset-face (face) | 349 (defun reset-face (face &optional locale tag-set exact-p) |
350 "Clear all existing built-in specifications from FACE. | 350 "Clear all existing built-in specifications from FACE. |
351 This makes FACE inherit all its display properties from 'default. | 351 This makes FACE inherit all its display properties from 'default. |
352 WARNING: Be absolutely sure you want to do this!!! It is a dangerous | 352 WARNING: Be absolutely sure you want to do this!!! It is a dangerous |
353 operation and is not undoable." | 353 operation and is not undoable. |
354 (mapcar (lambda (x) | 354 |
355 (remove-specifier (face-property face x))) | 355 The arguments LOCALE, TAG-SET and EXACT-P are the same as for |
356 built-in-face-specifiers) | 356 `remove-specifier'." |
357 (mapc (lambda (x) | |
358 (remove-specifier (face-property face x) locale tag-set exact-p)) | |
359 built-in-face-specifiers) | |
357 nil) | 360 nil) |
358 | 361 |
359 (defun set-face-parent (face parent &optional locale tag-set how-to-add) | 362 (defun set-face-parent (face parent &optional locale tag-set how-to-add) |
360 "Set the parent of FACE to PARENT, for all properties. | 363 "Set the parent of FACE to PARENT, for all properties. |
361 This makes all properties of FACE inherit from PARENT." | 364 This makes all properties of FACE inherit from PARENT." |
454 particular window and buffer will be returned. | 457 particular window and buffer will be returned. |
455 | 458 |
456 See `face-property-instance' for more information." | 459 See `face-property-instance' for more information." |
457 (face-property-instance face 'foreground domain default no-fallback)) | 460 (face-property-instance face 'foreground domain default no-fallback)) |
458 | 461 |
462 (defun face-foreground-name (face &optional domain default no-fallback) | |
463 "Return the name of the given face's foreground color in the given domain. | |
464 | |
465 FACE may be either a face object or a symbol representing a face. | |
466 | |
467 Normally DOMAIN will be a window or nil (meaning the selected window), | |
468 and an instance object describing how the background appears in that | |
469 particular window and buffer will be returned. | |
470 | |
471 See `face-property-instance' for more information." | |
472 (color-instance-name (face-foreground-instance | |
473 face domain default no-fallback))) | |
474 | |
459 (defun set-face-foreground (face color &optional locale tag-set how-to-add) | 475 (defun set-face-foreground (face color &optional locale tag-set how-to-add) |
460 "Change the foreground of the given face. | 476 "Change the foreground of the given face. |
461 | 477 |
462 FACE may be either a face object or a symbol representing a face. | 478 FACE may be either a face object or a symbol representing a face. |
463 | 479 |
498 particular window and buffer will be returned. | 514 particular window and buffer will be returned. |
499 | 515 |
500 See `face-property-instance' for more information." | 516 See `face-property-instance' for more information." |
501 (face-property-instance face 'background domain default no-fallback)) | 517 (face-property-instance face 'background domain default no-fallback)) |
502 | 518 |
519 (defun face-background-name (face &optional domain default no-fallback) | |
520 "Return the name of the given face's background color in the given domain. | |
521 | |
522 FACE may be either a face object or a symbol representing a face. | |
523 | |
524 Normally DOMAIN will be a window or nil (meaning the selected window), | |
525 and an instance object describing how the background appears in that | |
526 particular window and buffer will be returned. | |
527 | |
528 See `face-property-instance' for more information." | |
529 (color-instance-name (face-background-instance | |
530 face domain default no-fallback))) | |
531 | |
503 (defun set-face-background (face color &optional locale tag-set how-to-add) | 532 (defun set-face-background (face color &optional locale tag-set how-to-add) |
504 "Change the background of the given face. | 533 "Change the background of the given face. |
505 | 534 |
506 FACE may be either a face object or a symbol representing a face. | 535 FACE may be either a face object or a symbol representing a face. |
507 | 536 |
595 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | 624 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
596 HOW-TO-ADD arguments." | 625 HOW-TO-ADD arguments." |
597 (interactive (face-interactive "display-table")) | 626 (interactive (face-interactive "display-table")) |
598 (set-face-property face 'display-table display-table locale tag-set | 627 (set-face-property face 'display-table display-table locale tag-set |
599 how-to-add)) | 628 how-to-add)) |
629 | |
630 ;; The following accessors and mutators are, IMHO, good | |
631 ;; implementation. Cf. with `make-face-bold'. | |
600 | 632 |
601 (defun face-underline-p (face &optional domain default no-fallback) | 633 (defun face-underline-p (face &optional domain default no-fallback) |
602 "Return whether the given face is underlined. | 634 "Return whether the given face is underlined. |
603 See `face-property-instance' for the semantics of the DOMAIN argument." | 635 See `face-property-instance' for the semantics of the DOMAIN argument." |
604 (face-property-instance face 'underline domain default no-fallback)) | 636 (face-property-instance face 'underline domain default no-fallback)) |
1009 '(([default] . t) | 1041 '(([default] . t) |
1010 ([bold] . t) | 1042 ([bold] . t) |
1011 ([italic] . [default]) | 1043 ([italic] . [default]) |
1012 ([bold-italic] . [bold])))) | 1044 ([bold-italic] . [bold])))) |
1013 | 1045 |
1046 | |
1047 ;; Why do the following two functions lose so badly in so many | |
1048 ;; circumstances? | |
1049 | |
1014 (defun make-face-smaller (face &optional locale) | 1050 (defun make-face-smaller (face &optional locale) |
1015 "Make the font of the given face be smaller, if possible. | 1051 "Make the font of the given face be smaller, if possible. |
1016 LOCALE works as in `make-face-bold' et al., but the ``inheriting- | 1052 LOCALE works as in `make-face-bold' et al., but the ``inheriting- |
1017 from-the-bold-face'' operations described there are not done | 1053 from-the-bold-face'' operations described there are not done |
1018 because they don't make sense in this context." | 1054 because they don't make sense in this context." |
1066 "Return whether FACE is proportional. | 1102 "Return whether FACE is proportional. |
1067 See `face-property-instance' for the semantics of the DOMAIN argument." | 1103 See `face-property-instance' for the semantics of the DOMAIN argument." |
1068 (font-proportional-p (face-font face) domain charset)) | 1104 (font-proportional-p (face-font face) domain charset)) |
1069 | 1105 |
1070 | 1106 |
1071 (defvar init-face-from-resources t | 1107 ;; Functions that used to be in cus-face.el, but logically go here. |
1072 "If non-nil, attempt to initialize faces from the resource database.") | 1108 |
1073 | 1109 (defcustom frame-background-mode nil |
1110 "*The brightness of the background. | |
1111 Set this to the symbol dark if your background color is dark, light if | |
1112 your background is light, or nil (default) if you want Emacs to | |
1113 examine the brightness for you." | |
1114 :group 'faces | |
1115 :type '(choice (choice-item dark) | |
1116 (choice-item light) | |
1117 (choice-item :tag "Auto" nil))) | |
1118 | |
1119 ;; The old variable that many people still have in .emacs files. | |
1120 (define-obsolete-variable-alias 'custom-background-mode | |
1121 'frame-background-mode) | |
1122 | |
1123 (defun get-frame-background-mode (frame) | |
1124 "Detect background mode for FRAME." | |
1125 (let* ((color-instance (face-background-instance 'default frame)) | |
1126 (mode (condition-case nil | |
1127 (if (< (apply '+ (color-instance-rgb-components | |
1128 color-instance)) 65536) | |
1129 'dark 'light) | |
1130 ;; We'll get an error on a TTY; TTY-s are generally | |
1131 ;; dark. ### That's a good one. | |
1132 (error 'dark)))) | |
1133 (set-frame-property frame 'background-mode mode) | |
1134 mode)) | |
1135 | |
1136 (defun extract-custom-frame-properties (frame) | |
1137 "Return a plist with the frame properties of FRAME used by custom." | |
1138 (list 'type (or (frame-property frame 'display-type) | |
1139 (device-type (frame-device frame))) | |
1140 'class (device-class (frame-device frame)) | |
1141 'background (or frame-background-mode | |
1142 (frame-property frame 'background-mode) | |
1143 (get-frame-background-mode frame)))) | |
1144 | |
1145 (defcustom init-face-from-resources t | |
1146 "If non nil, attempt to initialize faces from the resource database." | |
1147 :group 'faces | |
1148 :type 'boolean) | |
1149 | |
1150 ;; Old name, used by custom. Also, FSFmacs name. | |
1151 (defvaralias 'initialize-face-resources 'init-face-from-resources) | |
1152 | |
1153 (defun face-spec-set (face spec &optional frame) | |
1154 "Set FACE's face attributes according to the first matching entry in SPEC. | |
1155 If optional FRAME is non-nil, set it for that frame only. | |
1156 If it is nil, then apply SPEC to each frame individually. | |
1157 See `defface' for information about SPEC." | |
1158 (if frame | |
1159 (progn | |
1160 (reset-face face frame) | |
1161 (face-display-set face spec frame)) | |
1162 (let ((frames (relevant-custom-frames))) | |
1163 (reset-face face) | |
1164 (face-display-set face spec) | |
1165 (while frames | |
1166 (face-display-set face spec (car frames)) | |
1167 (pop frames))))) | |
1168 | |
1169 (defun face-display-set (face spec &optional frame) | |
1170 "Set FACE to the attributes to the first matching entry in SPEC. | |
1171 Iff optional FRAME is non-nil, set it for that frame only. | |
1172 See `defface' for information about SPEC." | |
1173 (while spec | |
1174 (let ((display (caar spec)) | |
1175 (atts (cadar spec))) | |
1176 (pop spec) | |
1177 (when (face-spec-set-match-display display frame) | |
1178 ;; Avoid creating frame local duplicates of the global face. | |
1179 (unless (and frame (eq display (get face 'custom-face-display))) | |
1180 (apply 'face-custom-attributes-set face frame atts)) | |
1181 (unless frame | |
1182 (put face 'custom-face-display display)) | |
1183 (setq spec nil))))) | |
1184 | |
1185 (defvar default-custom-frame-properties nil | |
1186 "The frame properties used for the global faces. | |
1187 Frames not matching these propertiess should have frame local faces. | |
1188 The value should be nil, if uninitialized, or a plist otherwise. | |
1189 See `defface' for a list of valid keys and values for the plist.") | |
1190 | |
1191 (defun get-custom-frame-properties (&optional frame) | |
1192 "Return a plist with the frame properties of FRAME used by custom. | |
1193 If FRAME is nil, return the default frame properties." | |
1194 (cond (frame | |
1195 ;; Try to get from cache. | |
1196 (let ((cache (frame-property frame 'custom-properties))) | |
1197 (unless cache | |
1198 ;; Oh well, get it then. | |
1199 (setq cache (extract-custom-frame-properties frame)) | |
1200 ;; and cache it... | |
1201 (set-frame-property frame 'custom-properties cache)) | |
1202 cache)) | |
1203 (default-custom-frame-properties) | |
1204 (t | |
1205 (setq default-custom-frame-properties | |
1206 (extract-custom-frame-properties (selected-frame)))))) | |
1207 | |
1208 (defun face-spec-set-match-display (display frame) | |
1209 "Non-nil iff DISPLAY matches FRAME. | |
1210 DISPLAY is part of a spec such as can be used in `defface'. | |
1211 If FRAME is nil, the current FRAME is used." | |
1212 (if (eq display t) | |
1213 t | |
1214 (let* ((props (get-custom-frame-properties frame)) | |
1215 (type (plist-get props 'type)) | |
1216 (class (plist-get props 'class)) | |
1217 (background (plist-get props 'background)) | |
1218 (match t) | |
1219 (entries display) | |
1220 entry req options) | |
1221 (while (and entries match) | |
1222 (setq entry (car entries) | |
1223 entries (cdr entries) | |
1224 req (car entry) | |
1225 options (cdr entry) | |
1226 match (cond ((eq req 'type) | |
1227 (memq type options)) | |
1228 ((eq req 'class) | |
1229 (memq class options)) | |
1230 ((eq req 'background) | |
1231 (memq background options)) | |
1232 (t | |
1233 (warn "Unknown req `%S' with options `%S'" | |
1234 req options) | |
1235 nil)))) | |
1236 match))) | |
1237 | |
1238 (defun relevant-custom-frames () | |
1239 "List of frames whose custom properties differ from the default." | |
1240 (let ((relevant nil) | |
1241 (default (get-custom-frame-properties)) | |
1242 (frames (frame-list)) | |
1243 frame) | |
1244 (while frames | |
1245 (setq frame (car frames) | |
1246 frames (cdr frames)) | |
1247 (unless (equal default (get-custom-frame-properties frame)) | |
1248 (push frame relevant))) | |
1249 relevant)) | |
1250 | |
1251 (defun initialize-custom-faces (&optional frame) | |
1252 "Initialize all custom faces for FRAME. | |
1253 If FRAME is nil or omitted, initialize them for all frames." | |
1254 (mapc (lambda (symbol) | |
1255 (let ((spec (or (get symbol 'saved-face) | |
1256 (get symbol 'face-defface-spec)))) | |
1257 (when spec | |
1258 ;; No need to init-face-from-resources -- code in | |
1259 ;; `init-frame-faces' does it already. | |
1260 (face-display-set symbol spec frame)))) | |
1261 (face-list))) | |
1262 | |
1263 (defun custom-initialize-frame (frame) | |
1264 "Initialize frame-local custom faces for FRAME if necessary." | |
1265 (unless (equal (get-custom-frame-properties) | |
1266 (get-custom-frame-properties frame)) | |
1267 (initialize-custom-faces frame))) | |
1268 | |
1269 | |
1270 | |
1074 (defun make-empty-face (name &optional doc-string temporary) | 1271 (defun make-empty-face (name &optional doc-string temporary) |
1075 "Like `make-face', but doesn't query the resource database." | 1272 "Like `make-face', but doesn't query the resource database." |
1076 (let ((init-face-from-resources nil)) | 1273 (let ((init-face-from-resources nil)) |
1077 (make-face name doc-string temporary))) | 1274 (make-face name doc-string temporary))) |
1078 | 1275 |
1161 (when (face-equal 'bold 'bold-italic) | 1358 (when (face-equal 'bold 'bold-italic) |
1162 (copy-face 'italic 'bold-italic) | 1359 (copy-face 'italic 'bold-italic) |
1163 (make-face-bold 'bold-italic)) | 1360 (make-face-bold 'bold-italic)) |
1164 ;; | 1361 ;; |
1165 ;; Nothing more to be done for X or TTY's? | 1362 ;; Nothing more to be done for X or TTY's? |
1166 ) | 1363 ) |
1167 | 1364 |
1168 | 1365 |
1169 ;; These warnings are there for a reason. | 1366 ;; These warnings are there for a reason. |
1170 ;; Just specify your fonts correctly. Deal with it. | 1367 ;; Just specify your fonts correctly. Deal with it. |
1171 ;(defvar inhibit-font-complaints nil | 1368 ;(defvar inhibit-font-complaints nil |
1248 (unless (face-differs-from-default-p 'bold-italic device) | 1445 (unless (face-differs-from-default-p 'bold-italic device) |
1249 ;; then bitch and moan. | 1446 ;; then bitch and moan. |
1250 (face-complain-about-font 'bold-italic device)))))) | 1447 (face-complain-about-font 'bold-italic device)))))) |
1251 | 1448 |
1252 ;; Set the text-cursor colors unless already specified. | 1449 ;; Set the text-cursor colors unless already specified. |
1253 (when (and (not (face-background 'text-cursor 'global)) | 1450 (when (and (not (eq 'tty (device-type device))) |
1451 (not (face-background 'text-cursor 'global)) | |
1254 (face-property-equal 'text-cursor 'default 'background device)) | 1452 (face-property-equal 'text-cursor 'default 'background device)) |
1255 (set-face-background 'text-cursor [default foreground] 'global | 1453 (set-face-background 'text-cursor [default foreground] 'global |
1256 nil 'append)) | 1454 nil 'append)) |
1257 (when (and (not (face-foreground 'text-cursor 'global)) | 1455 (when (and (not (eq 'tty (device-type device))) |
1456 (not (face-foreground 'text-cursor 'global)) | |
1258 (face-property-equal 'text-cursor 'default 'foreground device)) | 1457 (face-property-equal 'text-cursor 'default 'foreground device)) |
1259 (set-face-foreground 'text-cursor [default background] 'global | 1458 (set-face-foreground 'text-cursor [default background] 'global |
1260 nil 'append)) | 1459 nil 'append)) |
1261 | 1460 |
1262 ;; Set the secondary-selection color unless already specified. | 1461 ;; Set the secondary-selection color unless already specified. |
1350 'global)) | 1549 'global)) |
1351 ;; if the isearch face isn't distinguished (e.g. we're not on a color | 1550 ;; if the isearch face isn't distinguished (e.g. we're not on a color |
1352 ;; display), at least try making it bold. | 1551 ;; display), at least try making it bold. |
1353 (unless (face-differs-from-default-p 'isearch device) | 1552 (unless (face-differs-from-default-p 'isearch device) |
1354 (set-face-font 'isearch [bold])) | 1553 (set-face-font 'isearch [bold])) |
1355 | |
1356 ;; Set the modeline face colors/fonts unless already specified. | |
1357 | |
1358 ;; modeline-buffer-id: | |
1359 (unless (face-differs-from-default-p 'modeline-buffer-id device) | |
1360 (let ((fg (face-foreground 'modeline-buffer-id 'global)) | |
1361 (font (face-font 'modeline-buffer-id 'global))) | |
1362 (when (and (null fg) (featurep 'x)) | |
1363 (set-face-foreground 'modeline-buffer-id "blue4" 'global '(color x))) | |
1364 (unless font | |
1365 (when (featurep 'x) | |
1366 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x)) | |
1367 (set-face-font 'modeline-buffer-id [bold-italic] nil '(grayscale x))) | |
1368 (when (featurep 'tty) | |
1369 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty))))) | |
1370 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append) | |
1371 | |
1372 ;; modeline-mousable: | |
1373 (unless (face-differs-from-default-p 'modeline-mousable device) | |
1374 (let ((fg (face-foreground 'modeline-mousable 'global)) | |
1375 (font (face-font 'modeline-mousable 'global))) | |
1376 (when (and (null fg) (featurep 'x)) | |
1377 (set-face-foreground 'modeline-mousable "firebrick" 'global '(color x))) | |
1378 (unless font | |
1379 (when (featurep 'x) | |
1380 (set-face-font 'modeline-mousable [bold] nil '(mono x)) | |
1381 (set-face-font 'modeline-mousable [bold] nil '(grayscale x)))))) | |
1382 (set-face-parent 'modeline-mousable 'modeline nil nil 'append) | |
1383 | |
1384 ;; modeline-mousable-minor-mode: | |
1385 (unless (face-differs-from-default-p 'modeline-mousable-minor-mode device) | |
1386 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global))) | |
1387 (when (and (null fg) (featurep 'x)) | |
1388 (set-face-foreground 'modeline-mousable-minor-mode | |
1389 '(((color x) . "green4") | |
1390 ((color x) . "forestgreen")) 'global)))) | |
1391 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable | |
1392 nil nil 'append) | |
1393 ) | 1554 ) |
1394 | 1555 |
1395 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones. | 1556 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle Jones. |
1396 (defun set-face-stipple (face pixmap &optional frame) | 1557 (defun set-face-stipple (face pixmap &optional frame) |
1397 "Change the stipple pixmap of face FACE to PIXMAP. | 1558 "Change the stipple pixmap of face FACE to PIXMAP. |
1475 (set-face-underline-p 'bold-italic t 'global 'tty) | 1636 (set-face-underline-p 'bold-italic t 'global 'tty) |
1476 (set-face-highlight-p 'highlight t 'global 'tty) | 1637 (set-face-highlight-p 'highlight t 'global 'tty) |
1477 (set-face-reverse-p 'text-cursor t 'global 'tty) | 1638 (set-face-reverse-p 'text-cursor t 'global 'tty) |
1478 (set-face-reverse-p 'modeline t 'global 'tty) | 1639 (set-face-reverse-p 'modeline t 'global 'tty) |
1479 (set-face-reverse-p 'zmacs-region t 'global 'tty) | 1640 (set-face-reverse-p 'zmacs-region t 'global 'tty) |
1641 (set-face-reverse-p 'primary-selection t 'global 'tty) | |
1642 (set-face-underline-p 'secondary-selection t 'global 'tty) | |
1480 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty) | 1643 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty) |
1481 (set-face-reverse-p 'isearch t 'global 'tty) | 1644 (set-face-reverse-p 'isearch t 'global 'tty) |
1482 ) | 1645 ) |
1483 | 1646 |
1484 ;;; faces.el ends here | 1647 ;;; faces.el ends here |