Mercurial > hg > xemacs-beta

comparison lisp/faces.el @ 4764:dec62ca5a899

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Prevent font frobbers from operating on TTY specs.
author Stephen J. Turnbull <stephen@xemacs.org>
date Fri, 04 Dec 2009 10:56:38 +0900
parents e14f9fdd5096
children e29fcfd8df5f
comparison
equal deleted inserted replaced
4758:75975fd0b7fc 4764:dec62ca5a899
931 frob-mapping standard-face-mapping) 931 frob-mapping standard-face-mapping)
932 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET 932 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET
933 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are 933 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are
934 ;; what we expect the original face and the result to look like, 934 ;; what we expect the original face and the result to look like,
935 ;; respectively. TTY-PROPS is a list of face properties to frob in place 935 ;; respectively. TTY-PROPS is a list of face properties to frob in place
936 ;; of `font' for TTY's. FROB-MAPPING is either a plist mapping device 936 ;; of `font' for TTYs. FROB-MAPPING is either a plist mapping device
937 ;; types to functions of two args (NAME DEVICE) that will frob the 937 ;; types to functions of two args (NAME DEVICE) that will frob the
938 ;; instantiator as appropriate for the device type (this includes TTY's), 938 ;; instantiator to NAME as appropriate for DEVICE's type (this includes
939 ;; or a function to handle the mapping for all device types. 939 ;; TTYs #### TTYs are not passed the device, just the symbol 'tty), or a
940 ;; function to handle the mapping for all device types.
940 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance 941 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance
941 ;; instantiators to be replaced with other inheritance instantiators, meant 942 ;; instantiators to be replaced with other inheritance instantiators, meant
942 ;; for e.g. converting [bold] into [bold-italic]. 943 ;; for e.g. converting [bold] into [bold-italic].
943 944
944 ;; #### it would be nice if this function could be generalized to be 945 ;; #### it would be nice if this function could be generalized to be
1036 tag-set)))))) 1037 tag-set))))))
1037 ;; (3) not a vector. just process it. 1038 ;; (3) not a vector. just process it.
1038 (t 1039 (t
1039 (let ((value 1040 (let ((value
1040 (if (eq devtype-spec 'tty) 1041 (if (eq devtype-spec 'tty)
1041 (funcall mapper x) 1042 ;; #### not quite right but need
1043 ;; two args to match documentation
1044 ;; mostly we just ignore TTYs so
1045 ;; for now just pass the devtype
1046 (funcall mapper x 'tty)
1042 (funcall mapper x 1047 (funcall mapper x
1043 (derive-domain-from-locale 1048 (derive-domain-from-locale
1044 locale devtype-spec 1049 locale devtype-spec
1045 ffpdev))))) 1050 ffpdev)))))
1046 (and (nil-instantiator-ok value devtype-spec) 1051 (and (nil-instantiator-ok value devtype-spec)
1191 (interactive (list (read-face-name "Set family of which face: ") 1196 (interactive (list (read-face-name "Set family of which face: ")
1192 (read-string "Family to set: "))) 1197 (read-string "Family to set: ")))
1193 1198
1194 (Face-frob-property face locale tags exact-p 1199 (Face-frob-property face locale tags exact-p
1195 nil nil 'font nil 1200 nil nil 'font nil
1201 ;; #### this code is duplicated in make-face-size
1196 `(lambda (f d) 1202 `(lambda (f d)
1197 ;; keep the dependency on font.el for now 1203 ;; keep the dependency on font.el for now
1198 (let ((fo (font-create-object f d))) 1204 ;; #### The filter on null d is a band-aid.
1199 (set-font-family fo ,family) 1205 ;; Frob-face-property should not be passing in
1200 (font-create-name fo d))) 1206 ;; null devices.
1207 (unless (or (null d) (eq d 'tty))
1208 (let ((fo (font-create-object f d)))
1209 (set-font-family fo ,family)
1210 (font-create-name fo d))))
1201 nil)) 1211 nil))
1202 1212
1203 ;; Style (ie, typographical face) frobbing 1213 ;; Style (ie, typographical face) frobbing
1204 (defun make-face-bold (face &optional locale tags exact-p) 1214 (defun make-face-bold (face &optional locale tags exact-p)
1205 "Make FACE bold in LOCALE, if possible. 1215 "Make FACE bold in LOCALE, if possible.
1309 make-face-unitalic italic default underline nil 1319 make-face-unitalic italic default underline nil
1310 " 1320 "
1311 (interactive (list (read-face-name "Make which face bold: "))) 1321 (interactive (list (read-face-name "Make which face bold: ")))
1312 (Face-frob-property face locale tags exact-p 1322 (Face-frob-property face locale tags exact-p
1313 'default 'bold 'font '(highlight) 1323 'default 'bold 'font '(highlight)
1314 '(tty (lambda (x) t) 1324 '(tty (lambda (f d) t)
1315 x x-make-font-bold 1325 x x-make-font-bold
1316 gtk gtk-make-font-bold 1326 gtk gtk-make-font-bold
1317 mswindows mswindows-make-font-bold 1327 mswindows mswindows-make-font-bold
1318 msprinter mswindows-make-font-bold) 1328 msprinter mswindows-make-font-bold)
1319 '(([default] . [bold]) 1329 '(([default] . [bold])
1328 the semantics of the LOCALE argument and for more specifics on exactly 1338 the semantics of the LOCALE argument and for more specifics on exactly
1329 how this function works." 1339 how this function works."
1330 (interactive (list (read-face-name "Make which face italic: "))) 1340 (interactive (list (read-face-name "Make which face italic: ")))
1331 (Face-frob-property face locale tags exact-p 1341 (Face-frob-property face locale tags exact-p
1332 'default 'italic 'font '(underline) 1342 'default 'italic 'font '(underline)
1333 '(tty (lambda (x) t) 1343 '(tty (lambda (f d) t)
1334 x x-make-font-italic 1344 x x-make-font-italic
1335 gtk gtk-make-font-italic 1345 gtk gtk-make-font-italic
1336 mswindows mswindows-make-font-italic 1346 mswindows mswindows-make-font-italic
1337 msprinter mswindows-make-font-italic) 1347 msprinter mswindows-make-font-italic)
1338 '(([default] . [italic]) 1348 '(([default] . [italic])
1347 locales. See `make-face-bold' for the semantics of the LOCALE 1357 locales. See `make-face-bold' for the semantics of the LOCALE
1348 argument and for more specifics on exactly how this function works." 1358 argument and for more specifics on exactly how this function works."
1349 (interactive (list (read-face-name "Make which face bold-italic: "))) 1359 (interactive (list (read-face-name "Make which face bold-italic: ")))
1350 (Face-frob-property face locale tags exact-p 1360 (Face-frob-property face locale tags exact-p
1351 'default 'bold-italic 'font '(underline highlight) 1361 'default 'bold-italic 'font '(underline highlight)
1352 '(tty (lambda (x) t) 1362 '(tty (lambda (f d) t)
1353 x x-make-font-bold-italic 1363 x x-make-font-bold-italic
1354 gtk gtk-make-font-bold-italic 1364 gtk gtk-make-font-bold-italic
1355 mswindows mswindows-make-font-bold-italic 1365 mswindows mswindows-make-font-bold-italic
1356 msprinter mswindows-make-font-bold-italic) 1366 msprinter mswindows-make-font-bold-italic)
1357 '(([default] . [italic]) 1367 '(([default] . [italic])
1367 `make-face-bold' for the semantics of the LOCALE argument and for more 1377 `make-face-bold' for the semantics of the LOCALE argument and for more
1368 specifics on exactly how this function works." 1378 specifics on exactly how this function works."
1369 (interactive (list (read-face-name "Make which face non-bold: "))) 1379 (interactive (list (read-face-name "Make which face non-bold: ")))
1370 (Face-frob-property face locale tags exact-p 1380 (Face-frob-property face locale tags exact-p
1371 'bold 'default 'font '(highlight) 1381 'bold 'default 'font '(highlight)
1372 '(tty (lambda (x) nil) 1382 '(tty (lambda (f d) nil)
1373 x x-make-font-unbold 1383 x x-make-font-unbold
1374 gtk gtk-make-font-unbold 1384 gtk gtk-make-font-unbold
1375 mswindows mswindows-make-font-unbold 1385 mswindows mswindows-make-font-unbold
1376 msprinter mswindows-make-font-unbold) 1386 msprinter mswindows-make-font-unbold)
1377 '(([default] . t) 1387 '(([default] . t)
1386 `make-face-bold' for the semantics of the LOCALE argument and for more 1396 `make-face-bold' for the semantics of the LOCALE argument and for more
1387 specifics on exactly how this function works." 1397 specifics on exactly how this function works."
1388 (interactive (list (read-face-name "Make which face non-italic: "))) 1398 (interactive (list (read-face-name "Make which face non-italic: ")))
1389 (Face-frob-property face locale tags exact-p 1399 (Face-frob-property face locale tags exact-p
1390 'italic 'default 'font '(underline) 1400 'italic 'default 'font '(underline)
1391 '(tty (lambda (x) nil) 1401 '(tty (lambda (f d) nil)
1392 x x-make-font-unitalic 1402 x x-make-font-unitalic
1393 gtk gtk-make-font-unitalic 1403 gtk gtk-make-font-unitalic
1394 mswindows mswindows-make-font-unitalic 1404 mswindows mswindows-make-font-unitalic
1395 msprinter mswindows-make-font-unitalic) 1405 msprinter mswindows-make-font-unitalic)
1396 '(([default] . t) 1406 '(([default] . t)
1406 "Adjust FACE to SIZE in LOCALE, if possible." 1416 "Adjust FACE to SIZE in LOCALE, if possible."
1407 (interactive (list (read-face-name "Set size of which face: ") 1417 (interactive (list (read-face-name "Set size of which face: ")
1408 (read-number "Size to set: " t 10))) 1418 (read-number "Size to set: " t 10)))
1409 (Face-frob-property face locale tags exact-p 1419 (Face-frob-property face locale tags exact-p
1410 nil nil 'font nil 1420 nil nil 'font nil
1421 ;; #### this code is duplicated in make-face-family
1411 `(lambda (f d) 1422 `(lambda (f d)
1412 ;; keep the dependency on font.el for now 1423 ;; keep the dependency on font.el for now
1413 (let ((fo (font-create-object f d))) 1424 ;; #### The filter on null d is a band-aid.
1414 (set-font-size fo ,size) 1425 ;; Frob-face-property should not be passing in
1415 (font-create-name fo d))) 1426 ;; null devices.
1427 (unless (or (null d) (eq d 'tty))
1428 (let ((fo (font-create-object f d)))
1429 (set-font-size fo ,size)
1430 (font-create-name fo d))))
1416 nil)) 1431 nil))
1417 1432
1418 ;; Why do the following two functions lose so badly in so many 1433 ;; Why do the following two functions lose so badly in so many
1419 ;; circumstances? 1434 ;; circumstances?
1420 1435