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