Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 138:6608ceec7cf8 r20-2b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-2b3
author cvs
date Mon, 13 Aug 2007 09:31:46 +0200
parents b980b6286996
children 489f57a838ef
comparison
equal deleted inserted replaced
137:cae984061f40 138:6608ceec7cf8
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/04/20 19:19:45 3 ;; Created: 1997/04/24 13:55:44
4 ;; Version: 1.45 4 ;; Version: 1.51
5 ;; Keywords: faces 5 ;; Keywords: faces
6 6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu) 8 ;;; Copyright (c) 1995, 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
28 28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; The emacsen compatibility package - load it up before anything else 30 ;;; The emacsen compatibility package - load it up before anything else
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (require 'cl) 32 (require 'cl)
33 (require 'devices)
33 34
34 (eval-and-compile 35 (eval-and-compile
35 (require 'devices)) 36 (condition-case ()
36 37 (require 'custom)
37 (eval-and-compile 38 (error nil))
38 (if (not (fboundp 'try-font-name)) 39 (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
39 (defsubst try-font-name (fontname &rest args) 40 nil ;; We've got what we needed
40 (case window-system 41 ;; We have the old custom-library, hack around it!
41 ((x win32 pm) (car-safe (x-list-fonts fontname))) 42 (defmacro defgroup (&rest args)
42 (ns (car-safe (ns-list-fonts fontname))) 43 nil)
43 (otherwise nil)))) 44 (defmacro defcustom (var value doc &rest args)
44 (if (not (fboundp 'facep)) 45 (` (defvar (, var) (, value) (, doc))))))
45 (defsubst facep (face) 46
46 "Return t if X is a face name or an internal face vector." 47 (if (not (fboundp 'try-font-name))
47 (if (not window-system) 48 (defun try-font-name (fontname &rest args)
48 nil ; FIXME if FSF ever does TTY faces 49 (case window-system
49 (and (or (internal-facep face) 50 ((x win32 pm) (car-safe (x-list-fonts fontname)))
50 (and (symbolp face) (assq face global-face-data))) 51 (ns (car-safe (ns-list-fonts fontname)))
51 t)))) 52 (otherwise nil))))
52 (if (not (fboundp 'set-face-property)) 53
53 (defsubst set-face-property (face property value &optional locale 54 (if (not (fboundp 'facep))
54 tag-set how-to-add) 55 (defun facep (face)
55 "Change a property of FACE." 56 "Return t if X is a face name or an internal face vector."
56 (and (symbolp face) 57 (if (not window-system)
57 (put face property value)))) 58 nil ; FIXME if FSF ever does TTY faces
58 (if (not (fboundp 'face-property)) 59 (and (or (internal-facep face)
59 (defsubst face-property (face property &optional locale tag-set exact-p) 60 (and (symbolp face) (assq face global-face-data)))
60 "Return FACE's value of the given PROPERTY." 61 t))))
61 (and (symbolp face) (get face property))))) 62
63 (if (not (fboundp 'set-face-property))
64 (defun set-face-property (face property value &optional locale
65 tag-set how-to-add)
66 "Change a property of FACE."
67 (and (symbolp face)
68 (put face property value))))
69
70 (if (not (fboundp 'face-property))
71 (defun face-property (face property &optional locale tag-set exact-p)
72 "Return FACE's value of the given PROPERTY."
73 (and (symbolp face) (get face property))))
62 74
63 (require 'disp-table) 75 (require 'disp-table)
64 76
65 (if (not (fboundp '<<)) (fset '<< 'lsh)) 77 (if (not (fboundp '<<)) (fset '<< 'lsh))
66 (if (not (fboundp '&)) (fset '& 'logand)) 78 (if (not (fboundp '&)) (fset '& 'logand))
297 type (car (pop todo))) 309 type (car (pop todo)))
298 (if (funcall func fontobj) 310 (if (funcall func fontobj)
299 (setq retval (cons type retval)))) 311 (setq retval (cons type retval))))
300 retval)) 312 retval))
301 313
302 (defun unique (list) 314 (defun font-unique (list)
303 (let ((retval) 315 (let ((retval)
304 (cur)) 316 (cur))
305 (while list 317 (while list
306 (setq cur (car list) 318 (setq cur (car list)
307 list (cdr list)) 319 list (cdr list))
413 (font-spatial-to-canonical (font-size fontobj-1)))) 425 (font-spatial-to-canonical (font-size fontobj-1))))
414 (size-2 (and (font-size fontobj-2) 426 (size-2 (and (font-size fontobj-2)
415 (font-spatial-to-canonical (font-size fontobj-2))))) 427 (font-spatial-to-canonical (font-size fontobj-2)))))
416 (set-font-weight retval (font-higher-weight (font-weight fontobj-1) 428 (set-font-weight retval (font-higher-weight (font-weight fontobj-1)
417 (font-weight fontobj-2))) 429 (font-weight fontobj-2)))
418 (set-font-family retval (unique (append (font-family fontobj-1) 430 (set-font-family retval (font-unique (append (font-family fontobj-1)
419 (font-family fontobj-2)))) 431 (font-family fontobj-2))))
420 (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2))) 432 (set-font-style retval (| (font-style fontobj-1) (font-style fontobj-2)))
421 (set-font-registry retval (or (font-registry fontobj-1) 433 (set-font-registry retval (or (font-registry fontobj-1)
422 (font-registry fontobj-2))) 434 (font-registry fontobj-2)))
423 (set-font-encoding retval (or (font-encoding fontobj-1) 435 (set-font-encoding retval (or (font-encoding fontobj-1)
424 (font-encoding fontobj-2))) 436 (font-encoding fontobj-2)))
568 (x-font-families-for-device device t)) 580 (x-font-families-for-device device t))
569 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 581 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
570 (aref menu 0))) 582 (aref menu 0)))
571 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 583 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
572 (aref menu 1)))) 584 (aref menu 1))))
573 (sort (unique (nconc scaled normal)) 'string-lessp)))) 585 (sort (font-unique (nconc scaled normal)) 'string-lessp))))
574 (cons "monospace" (mapcar 'car font-family-mappings)))) 586 (cons "monospace" (mapcar 'car font-family-mappings))))
575 587
576 (defvar font-default-cache nil) 588 (defvar font-default-cache nil)
577 589
578 ;;;###autoload 590 ;;;###autoload
709 (ns-font-families-for-device device t)) 721 (ns-font-families-for-device device t))
710 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0)))) 722 (let ((scaled (mapcar (function (lambda (x) (if x (aref x 0))))
711 (aref menu 0))) 723 (aref menu 0)))
712 (normal (mapcar (function (lambda (x) (if x (aref x 0)))) 724 (normal (mapcar (function (lambda (x) (if x (aref x 0))))
713 (aref menu 1)))) 725 (aref menu 1))))
714 (sort (unique (nconc scaled normal)) 'string-lessp)))))) 726 (sort (font-unique (nconc scaled normal)) 'string-lessp))))))
715 727
716 (defun ns-font-create-name (fontobj &optional device) 728 (defun ns-font-create-name (fontobj &optional device)
717 (let ((family (or (font-family fontobj) 729 (let ((family (or (font-family fontobj)
718 (ns-font-families-for-device device))) 730 (ns-font-families-for-device device)))
719 (weight (or (font-weight fontobj) :medium)) 731 (weight (or (font-weight fontobj) :medium))
1162 (apply 'set-face-foreground face (font-normalize-color color) args)) 1174 (apply 'set-face-foreground face (font-normalize-color color) args))
1163 (t 1175 (t
1164 (apply 'set-face-foreground face color args))) 1176 (apply 'set-face-foreground face color args)))
1165 (error nil))) 1177 (error nil)))
1166 1178
1179 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1180 ;;; Support for 'blinking' fonts
1181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1182 (defun font-map-windows (func &optional arg frame)
1183 (let* ((start (selected-window))
1184 (cur start)
1185 (result nil))
1186 (push (funcall func start arg) result)
1187 (while (not (eq start (setq cur (next-window cur))))
1188 (push (funcall func cur arg) result))
1189 result))
1190
1191 (defun font-face-visible-in-window-p (window face)
1192 (let ((st (window-start window))
1193 (nd (window-end window))
1194 (found nil)
1195 (face-at nil))
1196 (setq face-at (get-text-property st 'face (window-buffer window)))
1197 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
1198 (setq found t))
1199 (while (and (not found)
1200 (/= nd
1201 (setq st (next-single-property-change
1202 st 'face
1203 (window-buffer window) nd))))
1204 (setq face-at (get-text-property st 'face (window-buffer window)))
1205 (if (or (eq face face-at) (and (listp face-at) (memq face face-at)))
1206 (setq found t)))
1207 found))
1208
1209 (defun font-blink-callback ()
1210 ;; Optimized to never invert the face unless one of the visible windows
1211 ;; is showing it.
1212 (let ((faces (if font-running-xemacs (face-list t) (face-list)))
1213 (obj nil))
1214 (while faces
1215 (if (and (setq obj (face-property (car faces) 'font-specification))
1216 (font-blink-p obj)
1217 (memq t
1218 (font-map-windows 'font-face-visible-in-window-p (car faces))))
1219 (invert-face (car faces)))
1220 (pop faces))))
1221
1222 (defcustom font-blink-interval 0.5
1223 "How often to blink faces"
1224 :type 'number
1225 :group 'faces)
1226
1227 (defun font-blink-initialize ()
1228 (cond
1229 ((featurep 'itimer)
1230 (if (get-itimer "font-blinker")
1231 (delete-itimer (get-itimer "font-blinker")))
1232 (start-itimer "font-blinker" 'font-blink-callback
1233 font-blink-interval
1234 font-blink-interval))
1235 ((fboundp 'run-at-time)
1236 (cancel-function-timers 'font-blink-callback)
1237 (run-at-time font-blink-interval
1238 font-blink-interval
1239 'font-blink-callback))
1240 (t nil)))
1241
1167 (provide 'font) 1242 (provide 'font)