Mercurial > hg > xemacs-beta

comparison lisp/prim/faces.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children c7528f8e288d
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
29 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 29 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
30 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 30 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
31 ;; General Public License for more details. 31 ;; General Public License for more details.
32 32
33 ;; You should have received a copy of the GNU General Public License 33 ;; You should have received a copy of the GNU General Public License
34 ;; along with XEmacs; see the file COPYING. If not, write to the 34 ;; along with XEmacs; see the file COPYING. If not, write to the
35 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 35 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
36 ;; Boston, MA 02111-1307, USA. 36 ;; Boston, MA 02111-1307, USA.
37 37
38 ;;; Synched up with: Not synched with FSF. Almost completely divergent. 38 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
39 ;;; Some stuff in FSF's faces.el is in our x-faces.el. 39 ;;; Some stuff in FSF's faces.el is in our x-faces.el.
1067 "Return whether FACE is proportional. 1067 "Return whether FACE is proportional.
1068 See `face-property-instance' for the semantics of the DOMAIN argument." 1068 See `face-property-instance' for the semantics of the DOMAIN argument."
1069 (font-proportional-p (face-font face) domain charset)) 1069 (font-proportional-p (face-font face) domain charset))
1070 1070
1071 1071
1072 (defvar init-face-from-resources t
1073 "If non-nil, attempt to initialize faces from the resource database.")
1074
1075 (defun make-empty-face (name &optional doc-string temporary)
1076 "Like `make-face', but doesn't query the resource database."
1077 (let ((init-face-from-resources nil))
1078 (make-face name doc-string temporary)))
1079
1080 (defun init-face-from-resources (face &optional locale) 1072 (defun init-face-from-resources (face &optional locale)
1081 "Initialize FACE from the resource database. 1073 "Initialize FACE from the resource database.
1082 If LOCALE is specified, it should be a frame, device, or 'global, and 1074 If LOCALE is specified, it should be a frame, device, or 'global, and
1083 the face will be resourced over that locale. Otherwise, the face will 1075 the face will be resourced over that locale. Otherwise, the face will
1084 be resourced over all possible locales (i.e. all frames, all devices, 1076 be resourced over all possible locales (i.e. all frames, all devices,
1085 and 'global)." 1077 and 'global)."
1086 (cond ((null init-face-from-resources) 1078 (if (not locale)
1087 ;; Do nothing. 1079 (progn
1088 ) 1080 (init-face-from-resources face 'global)
1089 ((not locale) 1081 (let ((devices (device-list)))
1090 ;; Global, set for all frames. 1082 (while devices
1091 (progn 1083 (init-face-from-resources face (car devices))
1092 (init-face-from-resources face 'global) 1084 (setq devices (cdr devices))))
1093 (let ((devices (device-list))) 1085 (let ((frames (frame-list)))
1094 (while devices 1086 (while frames
1095 (init-face-from-resources face (car devices)) 1087 (init-face-from-resources face (car frames))
1096 (setq devices (cdr devices)))) 1088 (setq frames (cdr frames)))))
1097 (let ((frames (frame-list))) 1089 (let ((devtype (cond ((devicep locale) (device-type locale))
1098 (while frames 1090 ((framep locale) (frame-type locale))
1099 (init-face-from-resources face (car frames)) 1091 (t nil))))
1100 (setq frames (cdr frames)))))) 1092 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
1101 (t 1093 (x-init-face-from-resources face locale))
1102 ;; Specific. 1094 ((or (not devtype) (eq 'tty devtype))
1103 (let ((devtype (cond ((devicep locale) (device-type locale)) 1095 ;; Nothing to do for TTYs?
1104 ((framep locale) (frame-type locale)) 1096 )))))
1105 (t nil))))
1106 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype))
1107 (x-init-face-from-resources face locale))
1108 ((or (not devtype) (eq 'tty devtype))
1109 ;; Nothing to do for TTYs?
1110 ))))))
1111 1097
1112 (defun init-device-faces (device) 1098 (defun init-device-faces (device)
1113 ;; First, add any device-local face resources. 1099 ;; First, add any device-local face resources.
1114 (when init-face-from-resources 1100 (let ((faces (face-list)))
1115 (loop for face in (face-list) do 1101 (while faces
1116 (init-face-from-resources face device)) 1102 (init-face-from-resources (car faces) device)
1117 ;; Then do any device-specific initialization. 1103 (setq faces (cdr faces))))
1118 (cond ((eq 'x (device-type device)) 1104 ;; Then do any device-specific initialization.
1119 (x-init-device-faces device)) 1105 (cond ((eq 'x (device-type device))
1120 ;; Nothing to do for TTYs? 1106 (x-init-device-faces device))
1121 ) 1107 ;; Nothing to do for TTYs?
1122 (init-other-random-faces device))) 1108 )
1109 (init-other-random-faces device))
1123 1110
1124 (defun init-frame-faces (frame) 1111 (defun init-frame-faces (frame)
1125 (when init-face-from-resources 1112 ;; First, add any frame-local face resources.
1126 ;; First, add any frame-local face resources. 1113 (let ((faces (face-list)))
1127 (loop for face in (face-list) do 1114 (while faces
1128 (init-face-from-resources face frame)) 1115 (init-face-from-resources (car faces) frame)
1129 ;; Then do any frame-specific initialization. 1116 (setq faces (cdr faces))))
1130 (cond ((eq 'x (frame-type frame)) 1117 ;; Then do any frame-specific initialization.
1131 (x-init-frame-faces frame)) 1118 (cond ((eq 'x (frame-type frame))
1132 ;; Is there anything which should be done for TTY's? 1119 (x-init-frame-faces frame))
1133 ))) 1120 ;; Is there anything which should be done for TTY's?
1121 ))
1134 1122
1135 ;; #### This is somewhat X-specific, and is called when the first 1123 ;; #### This is somewhat X-specific, and is called when the first
1136 ;; X device is created (even if there were TTY devices created 1124 ;; X device is created (even if there were TTY devices created
1137 ;; beforehand). The concept of resources has not been generalized 1125 ;; beforehand). The concept of resources has not been generalized
1138 ;; outside of X-specificness, so we have to live with this 1126 ;; outside of X-specificness, so we have to live with this
1226 (make-face-bold 'italic device) ; bold if possible, then complain 1214 (make-face-bold 'italic device) ; bold if possible, then complain
1227 (face-complain-about-font 'italic device))) 1215 (face-complain-about-font 'italic device)))
1228 1216
1229 ;; similar for bold-italic. 1217 ;; similar for bold-italic.
1230 (or (face-differs-from-default-p 'bold-italic device) 1218 (or (face-differs-from-default-p 'bold-italic device)
1231 (make-face-bold 'bold-italic device)) 1219 (make-face-bold-italic 'bold-italic device))
1232 ;; if we couldn't get a bold-italic version, try just bold. 1220 ;; if we couldn't get a bold-italic version, try just bold.
1233 (or (face-differs-from-default-p 'bold-italic device) 1221 (or (face-differs-from-default-p 'bold-italic device)
1234 (make-face-bold-italic 'bold-italic device)) 1222 (make-face-bold-italic 'bold-italic device))
1235 ;; if we couldn't get bold or bold-italic, then that's probably because 1223 ;; if we couldn't get bold or bold-italic, then that's probably because
1236 ;; the default font is bold, so make the `bold-italic' face be unbold. 1224 ;; the default font is bold, so make the `bold-italic' face be unbold.
1280 (or (face-differs-from-default-p 'highlight device) 1268 (or (face-differs-from-default-p 'highlight device)
1281 (invert-face 'highlight device)) 1269 (invert-face 'highlight device))
1282 1270
1283 ;; first time through, set the zmacs-region color if it's not already 1271 ;; first time through, set the zmacs-region color if it's not already
1284 ;; specified. 1272 ;; specified.
1285 (unless (or (face-differs-from-default-p 'zmacs-region device) 1273 (if (and (not (face-differs-from-default-p 'zmacs-region device))
1286 (face-background 'zmacs-region 'global)) 1274 (not (face-background 'zmacs-region 'global)))
1287 (set-face-background 'zmacs-region "gray65" 'global 'color) 1275 (progn
1288 (set-face-background 'zmacs-region "gray65" 'global 'grayscale)) 1276 (set-face-background 'zmacs-region "gray" 'global 'color)
1277 (set-face-background 'zmacs-region "gray80" 'global 'grayscale)))
1289 (if (and (not (face-differs-from-default-p 'zmacs-region device)) 1278 (if (and (not (face-differs-from-default-p 'zmacs-region device))
1290 (not (face-background-pixmap 'zmacs-region 'global))) 1279 (not (face-background-pixmap 'zmacs-region 'global)))
1291 (progn 1280 (progn
1292 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color) 1281 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'color)
1293 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale) 1282 (set-face-background-pixmap 'zmacs-region [nothing] 'global 'grayscale)
1316 (or (face-differs-from-default-p 'list-mode-item-selected device) 1305 (or (face-differs-from-default-p 'list-mode-item-selected device)
1317 (invert-face 'list-mode-item-selected device)) 1306 (invert-face 'list-mode-item-selected device))
1318 1307
1319 ;; first time through, set the primary-selection color if it's not already 1308 ;; first time through, set the primary-selection color if it's not already
1320 ;; specified. 1309 ;; specified.
1321 (unless (or (face-differs-from-default-p 'primary-selection device) 1310 (if (and (not (face-differs-from-default-p 'primary-selection device))
1322 (face-background 'primary-selection 'global)) 1311 (not (face-background 'primary-selection 'global)))
1323 (set-face-background 'primary-selection "gray65" 'global 'color) 1312 (progn
1324 (set-face-background 'primary-selection "gray65" 'global 'grayscale)) 1313 (set-face-background 'primary-selection "gray" 'global 'color)
1314 (set-face-background 'primary-selection "gray80" 'global 'grayscale)))
1325 (if (and (not (face-differs-from-default-p 'secondary-selection device)) 1315 (if (and (not (face-differs-from-default-p 'secondary-selection device))
1326 (not (face-background-pixmap 'primary-selection 'global))) 1316 (not (face-background-pixmap 'primary-selection 'global)))
1327 (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono)) 1317 (set-face-background-pixmap 'primary-selection "gray3" 'global 'mono))
1328 ;; if the primary-selection face isn't distinguished on this device, 1318 ;; if the primary-selection face isn't distinguished on this device,
1329 ;; at least try inverting it. 1319 ;; at least try inverting it.
1368 (if (not (face-differs-from-default-p 'modeline-buffer-id device)) 1358 (if (not (face-differs-from-default-p 'modeline-buffer-id device))
1369 (let ((fg (face-foreground 'modeline-buffer-id 'global)) 1359 (let ((fg (face-foreground 'modeline-buffer-id 'global))
1370 (font (face-font 'modeline-buffer-id 'global))) 1360 (font (face-font 'modeline-buffer-id 'global)))
1371 (and (featurep 'x) 1361 (and (featurep 'x)
1372 (or fg 1362 (or fg
1373 (set-face-foreground 'modeline-buffer-id "blue4" 'global 1363 (set-face-foreground 'modeline-buffer-id "blue" 'global
1374 '(color x)))) 1364 '(color x))))
1375 (if font 1365 (if font
1376 nil 1366 nil
1377 (if (featurep 'x) 1367 (if (featurep 'x)
1378 (progn 1368 (progn
1379 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x)) 1369 (set-face-font 'modeline-buffer-id [bold-italic] nil '(mono x))
1380 (set-face-font 'modeline-buffer-id [bold-italic] nil 1370 (set-face-font 'modeline-buffer-id [bold-italic] nil
1381 '(grayscale x)))) 1371 '(grayscale x))))
1382 (if (featurep 'tty) 1372 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty))))
1383 (set-face-font 'modeline-buffer-id [bold-italic] nil 'tty)))))
1384 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append) 1373 (set-face-parent 'modeline-buffer-id 'modeline nil nil 'append)
1385 1374
1386 ;; modeline-mousable: 1375 ;; modeline-mousable:
1387 (if (not (face-differs-from-default-p 'modeline-mousable device)) 1376 (if (not (face-differs-from-default-p 'modeline-mousable device))
1388 (let ((fg (face-foreground 'modeline-mousable 'global)) 1377 (let ((fg (face-foreground 'modeline-mousable 'global))
1389 (font (face-font 'modeline-mousable 'global))) 1378 (font (face-font 'modeline-mousable 'global)))
1390 (and (featurep 'x) 1379 (and (featurep 'x)
1391 (or fg 1380 (or fg
1392 (set-face-foreground 'modeline-mousable "firebrick" 'global 1381 (set-face-foreground 'modeline-mousable "red" 'global
1393 '(color x)))) 1382 '(color x))))
1394 (if font 1383 (if font
1395 nil 1384 nil
1396 (if (featurep 'x) 1385 (if (featurep 'x)
1397 (progn 1386 (progn
1405 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global))) 1394 (let ((fg (face-foreground 'modeline-mousable-minor-mode 'global)))
1406 (and (featurep 'x) 1395 (and (featurep 'x)
1407 (or fg 1396 (or fg
1408 (set-face-foreground 'modeline-mousable-minor-mode 1397 (set-face-foreground 'modeline-mousable-minor-mode
1409 '(((color x) . "green4") 1398 '(((color x) . "green4")
1410 ((color x) . "forestgreen")) 1399 ((color x) . "green")) 'global)))))
1411 'global)))))
1412 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable 1400 (set-face-parent 'modeline-mousable-minor-mode 'modeline-mousable
1413 nil nil 'append) 1401 nil nil 'append)
1414 ) 1402 )
1415 1403
1416 1404
1478 (if (featurep 'tty) 1466 (if (featurep 'tty)
1479 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty)) 1467 (set-face-reverse-p 'list-mode-item-selected t 'global 'tty))
1480 ;; 1468 ;;
1481 (if (featurep 'tty) 1469 (if (featurep 'tty)
1482 (set-face-reverse-p 'isearch t 'global 'tty)) 1470 (set-face-reverse-p 'isearch t 'global 'tty))
1483
1484 ;;; faces.el ends here