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