|
428
|
1 ;;; msw-faces.el --- mswindows-specific face stuff.
|
|
|
2
|
|
|
3 ;;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
|
|
793
|
4 ;;; Copyright (C) 1995, 1996, 2002 Ben Wing.
|
|
428
|
5
|
|
|
6 ;; Author: Jamie Zawinski
|
|
|
7 ;; Modified by: Chuck Thompson
|
|
|
8 ;; Modified by: Ben Wing
|
|
|
9 ;; Modified by: Martin Buchholz
|
|
|
10 ;; Rewritten for mswindows by: Jonathan Harris
|
|
|
11
|
|
|
12 ;; This file is part of XEmacs.
|
|
|
13
|
|
|
14 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
15 ;; under the terms of the GNU General Public License as published by
|
|
|
16 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
17 ;; any later version.
|
|
|
18
|
|
|
19 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
22 ;; General Public License for more details.
|
|
|
23
|
|
|
24 ;; You should have received a copy of the GNU General Public License
|
|
|
25 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
26 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
27 ;; Boston, MA 02111-1307, USA.
|
|
|
28
|
|
|
29 ;; This file does the magic to parse mswindows font names, and make sure that
|
|
|
30 ;; the default and modeline attributes of new frames are specified enough.
|
|
|
31
|
|
1346
|
32 (globally-declare-boundp
|
|
|
33 '(mswindows-font-regexp mswindows-font-regexp-missing-1
|
|
|
34 mswindows-font-regexp-missing-2 mswindows-font-regexp-missing-3
|
|
|
35 mswindows-font-regexp-missing-4))
|
|
|
36
|
|
853
|
37 (defun mswindows-init-global-faces ()
|
|
|
38 (set-face-font 'gui-element "MS Sans Serif:Regular:8" nil 'mswindows))
|
|
793
|
39
|
|
428
|
40 (defun mswindows-init-device-faces (device)
|
|
442
|
41 (let ((color-default (device-system-metric device 'color-default))
|
|
|
42 (color-3d-face (device-system-metric device 'color-3d-face)))
|
|
|
43 ; Force creation of the default face font so that if it fails we get
|
|
|
44 ; an error now instead of a crash at frame creation.
|
|
|
45 (unless (face-font-instance 'default device)
|
|
|
46 (error "Can't find a suitable default font"))
|
|
872
|
47
|
|
|
48 ;; Don't set them on the device because then the global setting won't
|
|
|
49 ;; override them.
|
|
|
50 ;; #### Use device tags if we have multiple msprinter devices. (can we?)
|
|
442
|
51 (if (car color-default)
|
|
872
|
52 (set-face-foreground 'default (car color-default) nil
|
|
|
53 (device-type device)))
|
|
442
|
54 (if (cdr color-default)
|
|
872
|
55 (set-face-background 'default (cdr color-default) nil
|
|
|
56 (device-type device)))
|
|
442
|
57 (if (car color-3d-face)
|
|
872
|
58 (set-face-foreground 'gui-element (car color-3d-face) nil
|
|
|
59 (device-type device)))
|
|
442
|
60 (if (cdr color-3d-face)
|
|
872
|
61 (set-face-background 'gui-element (cdr color-3d-face) nil
|
|
|
62 (device-type device)))
|
|
793
|
63 ))
|
|
428
|
64
|
|
|
65 (defun mswindows-init-frame-faces (frame)
|
|
|
66 )
|
|
|
67
|
|
|
68 ;; Other functions expect these regexps
|
|
872
|
69 (let
|
|
|
70 ((- ":")
|
|
4022
|
71 ;; What happens if a font family contains a colon? I can't find any
|
|
|
72 ;; documentation on that, and don't have a font editor to hand to test.
|
|
|
73 (fontname "\\([^:]*\\)") ; 1
|
|
872
|
74 (style "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 2
|
|
|
75 (pointsize "\\([0-9]*\\)") ; 3
|
|
|
76 (effects "\\(\\(?:[a-zA-Z]+\\(?: +[a-zA-Z]+\\)*\\)?\\)") ; 4
|
|
|
77 ;; must match "OEM/DOS"
|
|
|
78 (charset "\\([a-zA-Z/ ]*\\)") ; 5
|
|
|
79 )
|
|
|
80 (defconst mswindows-font-regexp
|
|
|
81 (concat "^" fontname - style - pointsize - effects - charset "$"))
|
|
|
82 (defconst mswindows-font-regexp-missing-1
|
|
|
83 (concat "^" fontname - style - pointsize - effects "$"))
|
|
|
84 (defconst mswindows-font-regexp-missing-2
|
|
|
85 (concat "^" fontname - style - pointsize "$"))
|
|
|
86 (defconst mswindows-font-regexp-missing-3
|
|
|
87 (concat "^" fontname - style "$"))
|
|
|
88 (defconst mswindows-font-regexp-missing-4
|
|
|
89 (concat "^" fontname "$"))
|
|
|
90 )
|
|
428
|
91
|
|
|
92 ;;; Fill in missing parts of a font spec. This is primarily intended as a
|
|
|
93 ;;; helper function for the functions below.
|
|
|
94 ;;; mswindows fonts look like:
|
|
872
|
95 ;;; fontname[:[weight][ slant][:pointsize[:effects]]][:charset]
|
|
428
|
96 ;;; A minimal mswindows font spec looks like:
|
|
|
97 ;;; Courier New
|
|
|
98 ;;; A maximal mswindows font spec looks like:
|
|
|
99 ;;; Courier New:Bold Italic:10:underline strikeout:Western
|
|
872
|
100 (defun mswindows-canonicalize-font-name (font)
|
|
|
101 "Given a mswindows font or font name, return its name in canonical form.
|
|
|
102 This adds missing colons and fills in the style field with \"Regular\".
|
|
|
103 This does *NOT* fill in the point size or charset fields, because in those
|
|
|
104 cases an empty field is not equivalent to any particular field value, but a
|
|
|
105 wildcard allowing for any possible value (charset Western and point size 10
|
|
|
106 are chosen first, if they exist)."
|
|
|
107 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
108 ;; fill in missing colons
|
|
|
109 (setq font
|
|
|
110 (cond ((string-match mswindows-font-regexp font) font)
|
|
|
111 ((string-match mswindows-font-regexp-missing-1 font)
|
|
|
112 (concat font ":"))
|
|
|
113 ((string-match mswindows-font-regexp-missing-2 font)
|
|
|
114 (concat font "::"))
|
|
|
115 ((string-match mswindows-font-regexp-missing-3 font)
|
|
|
116 (concat font ":::"))
|
|
|
117 ((string-match mswindows-font-regexp-missing-4 font)
|
|
|
118 (concat font "::::"))
|
|
|
119 (t "::::")))
|
|
|
120 (or (string-match mswindows-font-regexp font) (error "can't parse %S" font))
|
|
|
121 (if (equal "" (match-string 2 font))
|
|
|
122 (concat (substring font 0 (match-beginning 2)) "Regular"
|
|
|
123 (substring font (match-beginning 2)))
|
|
|
124 font))
|
|
|
125
|
|
|
126 (defun mswindows-parse-font-style (style)
|
|
|
127 ;; Parse a style into a cons (WEIGHT . SLANT). WEIGHT will never be the
|
|
|
128 ;; empty string (it may be "Regular"), but SLANT will be empty for
|
|
|
129 ;; non-italic.
|
|
|
130 (save-match-data
|
|
|
131 (let ((case-fold-search t))
|
|
|
132 (cond ((equalp style "Italic") '("Regular" . "Italic"))
|
|
|
133 ((string-match "^\\([a-zA-Z ]+?\\) +Italic$" style)
|
|
|
134 (cons (match-string 1 style) "Italic"))
|
|
|
135 (t (cons style ""))))))
|
|
|
136
|
|
|
137 (defun mswindows-construct-font-style (weight slant)
|
|
|
138 ;; Construct the style from WEIGHT and SLANT. Opposite of
|
|
|
139 ;; mswindows-parse-font-style.
|
|
|
140 (cond ((and (equal slant "") (equal weight "")) "Regular")
|
|
|
141 ((equal slant "") weight)
|
|
|
142 ((or (equalp weight "Regular") (equal weight "")) slant)
|
|
|
143 (t (concat weight " " slant))))
|
|
|
144
|
|
|
145 (defun mswindows-frob-font-style (font which)
|
|
|
146 ;; Given a font name or font instance, return a name with the style field
|
|
|
147 ;; (which includes weight and/or slant) changed according to WHICH, a plist.
|
|
|
148 ;; If no entry found, don't change.
|
|
|
149 (if (null font) nil
|
|
|
150 (setq font (mswindows-canonicalize-font-name font))
|
|
|
151 (or (string-match mswindows-font-regexp font)
|
|
|
152 (error "can't parse %S" font))
|
|
|
153 (let* ((style (match-string 2 font))
|
|
|
154 (style-rep
|
|
|
155 (save-match-data
|
|
|
156 (or (loop for (x y) on which by #'cddr
|
|
|
157 if (string-match (concat "^" x "$") style)
|
|
|
158 return (replace-match y nil nil style))
|
|
|
159 style))))
|
|
|
160 (concat (substring font 0 (match-beginning 2))
|
|
|
161 style-rep
|
|
|
162 (substring font (match-end 2))))))
|
|
|
163
|
|
|
164 (defun mswindows-frob-font-style-and-sizify (font which &optional device)
|
|
|
165 (if (null font) nil
|
|
|
166 (let* ((oldwidth (if (font-instance-p font) (font-instance-width font)
|
|
|
167 (let ((fi (make-font-instance font device t)))
|
|
|
168 (and fi (font-instance-width fi)))))
|
|
|
169 (newname (mswindows-frob-font-style font which))
|
|
|
170 (newfont (make-font-instance newname device t)))
|
|
|
171 ;; Hack! On MS Windows, bold fonts (even monospaced) are often wider
|
|
|
172 ;; than the equivalent non-bold font. Making the bold font one point
|
|
|
173 ;; smaller usually makes it the same width (maybe at the expense of
|
|
|
174 ;; making it one pixel shorter). Do the same trick in both directions.
|
|
|
175 (when (font-instance-p newfont)
|
|
|
176 (let ((newerfont newfont))
|
|
|
177 (block nil
|
|
|
178 (while (and newerfont oldwidth)
|
|
|
179 (setq newfont newerfont)
|
|
|
180 (cond ((< (font-instance-width newfont) oldwidth)
|
|
|
181 (setq newerfont
|
|
|
182 (make-font-instance
|
|
|
183 (mswindows-find-larger-font newfont device)
|
|
|
184 device t))
|
|
|
185 (if (and newerfont
|
|
|
186 (> (font-instance-width newerfont) oldwidth))
|
|
|
187 (return nil)))
|
|
|
188 ((> (font-instance-width newfont) oldwidth)
|
|
|
189 (setq newerfont
|
|
|
190 (make-font-instance
|
|
|
191 (mswindows-find-smaller-font newfont device)
|
|
|
192 device t))
|
|
|
193 (if (and newerfont
|
|
|
194 (< (font-instance-width newerfont) oldwidth))
|
|
|
195 (return nil)))
|
|
|
196 (t (return nil))))))
|
|
|
197 (if (font-instance-p newfont) (font-instance-name newfont) newfont)))))
|
|
|
198
|
|
|
199 (defconst mswindows-nonbold-weight-regexp
|
|
|
200 ;; He looked so, so cool with the ultra light dangling from his mouth as
|
|
|
201 ;; his fingers spun out demisemiquavers from the keyboard ...
|
|
|
202 "\\(Regular\\|Thin\\|Extra Light\\|Ultra Light\\|Light\\|Normal\\|Medium\\|Semi Bold\\|Demi Bold\\)"
|
|
|
203 )
|
|
|
204 (defconst mswindows-bold-weight-regexp
|
|
|
205 "\\(Semi Bold\\|Demi Bold\\|Bold\\|Extra Bold\\|Ultra Bold\\|Heavy\\|Black\\)"
|
|
|
206 )
|
|
|
207
|
|
|
208 (defconst mswindows-make-font-bold-mapper
|
|
|
209 `(,mswindows-nonbold-weight-regexp "Bold"
|
|
|
210 "Italic" "Bold Italic"
|
|
|
211 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic"))
|
|
|
212
|
|
|
213 (defconst mswindows-make-font-nonbold-mapper
|
|
|
214 `(,mswindows-bold-weight-regexp "Regular"
|
|
|
215 ,(concat mswindows-bold-weight-regexp " Italic") "Italic"))
|
|
|
216
|
|
|
217 (defconst mswindows-make-font-italic-mapper
|
|
|
218 '("\\(.*\\)Italic" "\\1Italic"
|
|
|
219 "\\(.*\\)" "\\1 Italic"))
|
|
|
220
|
|
|
221 (defconst mswindows-make-font-unitalic-mapper
|
|
|
222 '("Italic" "Regular"
|
|
|
223 "\\(.*\\) Italic" "\\1"))
|
|
|
224
|
|
|
225 (defconst mswindows-make-font-bold-italic-mapper
|
|
|
226 `(,mswindows-nonbold-weight-regexp "Bold Italic"
|
|
|
227 ,(concat mswindows-nonbold-weight-regexp " Italic") "Bold Italic"
|
|
|
228 "Italic" "Bold Italic"
|
|
|
229 ,mswindows-bold-weight-regexp "\\1 Italic"))
|
|
428
|
230
|
|
|
231 (defun mswindows-make-font-bold (font &optional device)
|
|
|
232 "Given a mswindows font specification, this attempts to make a bold font.
|
|
|
233 If it fails, it returns nil."
|
|
872
|
234 (mswindows-frob-font-style-and-sizify font mswindows-make-font-bold-mapper
|
|
|
235 device))
|
|
428
|
236
|
|
|
237 (defun mswindows-make-font-unbold (font &optional device)
|
|
|
238 "Given a mswindows font specification, this attempts to make a non-bold font.
|
|
|
239 If it fails, it returns nil."
|
|
872
|
240 (mswindows-frob-font-style-and-sizify font mswindows-make-font-nonbold-mapper
|
|
|
241 device))
|
|
428
|
242
|
|
|
243 (defun mswindows-make-font-italic (font &optional device)
|
|
|
244 "Given a mswindows font specification, this attempts to make an `italic'
|
|
|
245 font. If it fails, it returns nil."
|
|
872
|
246 (try-font-name (mswindows-frob-font-style
|
|
|
247 font mswindows-make-font-italic-mapper) device))
|
|
428
|
248
|
|
|
249 (defun mswindows-make-font-unitalic (font &optional device)
|
|
|
250 "Given a mswindows font specification, this attempts to make a non-italic
|
|
|
251 font. If it fails, it returns nil."
|
|
872
|
252 (try-font-name (mswindows-frob-font-style
|
|
|
253 font mswindows-make-font-unitalic-mapper) device))
|
|
428
|
254
|
|
|
255 (defun mswindows-make-font-bold-italic (font &optional device)
|
|
|
256 "Given a mswindows font specification, this attempts to make a `bold-italic'
|
|
|
257 font. If it fails, it returns nil."
|
|
872
|
258 (mswindows-frob-font-style-and-sizify font
|
|
|
259 mswindows-make-font-bold-italic-mapper
|
|
|
260 device))
|
|
|
261
|
|
|
262 (defun mswindows-available-font-sizes (font device)
|
|
|
263 (if (font-instance-p font) (setq font (font-instance-name font)))
|
|
|
264 (setq font (mswindows-canonicalize-font-name font))
|
|
|
265 (or (string-match mswindows-font-regexp font) (error "Can't parse %S" font))
|
|
|
266 ;; turn pointsize into wildcard
|
|
|
267 (setq font
|
|
|
268 (concat (substring font 0 (match-beginning 3))
|
|
|
269 (substring font (match-end 3) (match-end 0))))
|
|
|
270 (sort
|
|
|
271 (delq nil
|
|
|
272 (mapcar #'(lambda (name)
|
|
|
273 (and (string-match mswindows-font-regexp name)
|
|
|
274 (string-to-int (substring name (match-beginning 3)
|
|
|
275 (match-end 3)))))
|
|
2527
|
276 (font-list font device)))
|
|
872
|
277 #'<))
|
|
|
278
|
|
|
279 (defun mswindows-frob-font-size (font up-p device)
|
|
|
280 (if (stringp font) (setq font (make-font-instance font device)))
|
|
|
281 (let* ((name (font-instance-name font))
|
|
|
282 (truename (font-instance-truename font))
|
|
|
283 (available (and truename
|
|
|
284 (mswindows-available-font-sizes truename device))))
|
|
|
285 (if (null available) nil
|
|
|
286 (or (string-match mswindows-font-regexp truename)
|
|
|
287 (error "can't parse %S" truename))
|
|
|
288 (let ((old-size (string-to-int
|
|
|
289 (substring truename
|
|
|
290 (match-beginning 3) (match-end 3)))))
|
|
|
291 (or (> old-size 0) (error "font truename has 0 pointsize?"))
|
|
|
292 (or (string-match mswindows-font-regexp name)
|
|
|
293 (error "can't parse %S" name))
|
|
|
294 (let ((newsize
|
|
|
295 ;; scalable fonts: change size by 1 point.
|
|
|
296 (if (= 0 (car available))
|
|
|
297 (if (and (not up-p) (= 1 old-size)) nil
|
|
|
298 (if up-p (1+ old-size) (1- old-size)))
|
|
|
299 ;; non-scalable fonts: take the next available size.
|
|
|
300 (if up-p
|
|
|
301 (loop for tail on available
|
|
|
302 if (eql (car tail) old-size)
|
|
|
303 return (cadr tail))
|
|
|
304 (loop for tail on available
|
|
|
305 if (eql (cadr tail) old-size)
|
|
|
306 return (car tail))))))
|
|
|
307 (and newsize
|
|
|
308 (concat (substring name 0 (match-beginning 3))
|
|
|
309 (int-to-string newsize)
|
|
|
310 (substring name (match-end 3) (match-end 0)))))))))
|
|
428
|
311
|
|
|
312 (defun mswindows-find-smaller-font (font &optional device)
|
|
|
313 "Loads a new version of the given font (or font name) 1 point smaller.
|
|
|
314 Returns the font if it succeeds, nil otherwise."
|
|
872
|
315 (mswindows-frob-font-size font nil device))
|
|
428
|
316
|
|
|
317 (defun mswindows-find-larger-font (font &optional device)
|
|
|
318 "Loads a new version of the given font (or font name) 1 point larger.
|
|
|
319 Returns the font if it succeeds, nil otherwise."
|
|
872
|
320 (mswindows-frob-font-size font t device))
|
