Mercurial > hg > xemacs-beta

comparison lisp/w3/font.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents 9ee227acff29
children 859a2309aef8
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; font.el --- New font model 1 ;;; font.el --- New font model
2 ;; Author: wmperry 2 ;; Author: wmperry
3 ;; Created: 1997/01/03 16:43:49 3 ;; Created: 1997/01/30 00:58:33
4 ;; Version: 1.22 4 ;; Version: 1.29
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 Free Software Foundation, Inc. 9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;; 10 ;;;
11 ;;; This file is part of GNU Emacs. 11 ;;; This file is part of GNU Emacs.
12 ;;; 12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify 13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by 14 ;;; it under the terms of the GNU General Public License as published by
46 ;;; Not much should need to be modified 46 ;;; Not much should need to be modified
47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version)) 48 (defconst font-running-xemacs (string-match "XEmacs" (emacs-version))
49 "Whether we are running in XEmacs or not.") 49 "Whether we are running in XEmacs or not.")
50 50
51 (defmacro defkeyword (keyword &optional docstring) 51 (defmacro define-font-keywords (&rest keys)
52 (list 'defconst keyword (list 'quote keyword) 52 (`
53 (or docstring "A keyword"))) 53 (eval-and-compile
54 (let ((keywords (quote (, keys))))
55 (while keywords
56 (or (boundp (car keywords))
57 (set (car keywords) (car keywords)))
58 (setq keywords (cdr keywords)))))))
54 59
55 (defconst font-window-system-mappings 60 (defconst font-window-system-mappings
56 '((x . (x-font-create-name x-font-create-object)) 61 '((x . (x-font-create-name x-font-create-object))
57 (ns . (ns-font-create-name ns-font-create-object)) 62 (ns . (ns-font-create-name ns-font-create-object))
63 (win32 . (x-font-create-name x-font-create-object)) ; Change? FIXME
64 (pm . (x-font-create-name x-font-create-object)) ; Change? FIXME
58 (tty . (tty-font-create-plist tty-font-create-object))) 65 (tty . (tty-font-create-plist tty-font-create-object)))
59 "An assoc list mapping device types to the function used to create 66 "An assoc list mapping device types to the function used to create
60 a font name from a font structure.") 67 a font name from a font structure.")
61 68
62 (defconst ns-font-weight-mappings 69 (defconst ns-font-weight-mappings
125 ("cursive" . ("sirene" 132 ("cursive" . ("sirene"
126 "zapf chancery")) 133 "zapf chancery"))
127 ) 134 )
128 "A list of font family mappings.") 135 "A list of font family mappings.")
129 136
130 (defkeyword :family "Keyword specifying the font family of a FONTOBJ.") 137 (define-font-keywords :family :style :size :registry :encoding)
131 138
132 (defkeyword :weight "Keyword specifying the font weight of a FONTOBJ.") 139 (define-font-keywords
133 (defkeyword :extra-light) 140 :weight :extra-light :light :demi-light :medium :normal :demi-bold
134 (defkeyword :light) 141 :bold :extra-bold)
135 (defkeyword :demi-light)
136 (defkeyword :medium)
137 (defkeyword :normal)
138 (defkeyword :demi-bold)
139 (defkeyword :bold)
140 (defkeyword :extra-bold)
141
142 (defkeyword :style "Keyword specifying the font style of a FONTOBJ.")
143 (defkeyword :size "Keyword specifying the font size of a FONTOBJ.")
144 (defkeyword :registry "Keyword specifying the registry of a FONTOBJ.")
145 (defkeyword :encoding "Keyword specifying the encoding of a FONTOBJ.")
146 142
147 (defvar font-style-keywords nil) 143 (defvar font-style-keywords nil)
148 144
149 (defsubst set-font-family (fontobj family) 145 (defsubst set-font-family (fontobj family)
150 (aset fontobj 1 family)) 146 (aset fontobj 1 family))
253 ;;; Utility functions 249 ;;; Utility functions
254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 (defsubst set-font-style-by-keywords (fontobj styles) 251 (defsubst set-font-style-by-keywords (fontobj styles)
256 (make-local-variable 'font-func) 252 (make-local-variable 'font-func)
257 (declare (special font-func)) 253 (declare (special font-func))
258 (while styles 254 (if (listp styles)
259 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords))) 255 (while styles
260 styles (cdr styles)) 256 (setq font-func (car-safe (cdr-safe (assq (car styles) font-style-keywords)))
257 styles (cdr styles))
258 (and (fboundp font-func) (funcall font-func fontobj t)))
259 (setq font-func (car-safe (cdr-safe (assq styles font-style-keywords))))
261 (and (fboundp font-func) (funcall font-func fontobj t)))) 260 (and (fboundp font-func) (funcall font-func fontobj t))))
262 261
263 (defsubst font-properties-from-style (fontobj) 262 (defsubst font-properties-from-style (fontobj)
264 (let ((style (font-style fontobj)) 263 (let ((style (font-style fontobj))
265 (todo font-style-keywords) 264 (todo font-style-keywords)
574 (let ((family (or (font-family fontobj) 573 (let ((family (or (font-family fontobj)
575 (font-default-family-for-device device) 574 (font-default-family-for-device device)
576 (x-font-families-for-device device))) 575 (x-font-families-for-device device)))
577 (weight (or (font-weight fontobj) :medium)) 576 (weight (or (font-weight fontobj) :medium))
578 (style (font-style fontobj)) 577 (style (font-style fontobj))
579 (size (or (font-size fontobj) (font-default-size-for-device device))) 578 (size (or (if font-running-xemacs
579 (font-size fontobj))
580 (font-default-size-for-device device)))
580 (registry (or (font-registry fontobj) "*")) 581 (registry (or (font-registry fontobj) "*"))
581 (encoding (or (font-encoding fontobj) "*"))) 582 (encoding (or (font-encoding fontobj) "*")))
582 (if (stringp family) 583 (if (stringp family)
583 (setq family (list family))) 584 (setq family (list family)))
584 (setq weight (font-higher-weight weight 585 (setq weight (font-higher-weight weight
1056 (cdr-safe (aref colors nearest)))) 1057 (cdr-safe (aref colors nearest))))
1057 1058
1058 (defun font-normalize-color (color &optional device) 1059 (defun font-normalize-color (color &optional device)
1059 "Return an RGB tuple, given any form of input. If an error occurs, black 1060 "Return an RGB tuple, given any form of input. If an error occurs, black
1060 is returned." 1061 is returned."
1061 (cond 1062 (case (device-type device)
1062 ((eq (device-type device) 'x) 1063 ((x pm win32)
1063 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color))) 1064 (apply 'format "#%02x%02x%02x" (font-color-rgb-components color)))
1064 ((eq (device-type device) 'tty) 1065 (tty
1065 (apply 'font-tty-find-closest-color (font-color-rgb-components color))) 1066 (apply 'font-tty-find-closest-color (font-color-rgb-components color)))
1066 ((eq (device-type device) 'ns) 1067 (ns
1067 (let ((vals (mapcar (function (lambda (x) (>> x 8))) 1068 (let ((vals (mapcar (function (lambda (x) (>> x 8)))
1068 (font-color-rgb-components color)))) 1069 (font-color-rgb-components color))))
1069 (apply 'format "RGB%02x%02x%02xff" vals))) 1070 (apply 'format "RGB%02x%02x%02xff" vals)))
1070 (t "black"))) 1071 (otherwise "black")))
1071 1072
1072 (defun font-set-face-background (&optional face color &rest args) 1073 (defun font-set-face-background (&optional face color &rest args)
1073 (interactive) 1074 (interactive)
1074 (if (interactive-p) 1075 (if (interactive-p)
1075 (call-interactively 'font-original-set-face-background) 1076 (call-interactively 'font-original-set-face-background)