17052
|
1 ;;; fontset.el --- Commands for handling fontset.
|
|
2
|
18377
|
3 ;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
|
|
4 ;; Licensed to the Free Software Foundation.
|
17052
|
5
|
|
6 ;; Keywords: mule, multilingual, fontset
|
|
7
|
|
8 ;; This file is part of GNU Emacs.
|
|
9
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
13 ;; any later version.
|
|
14
|
|
15 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
18 ;; GNU General Public License for more details.
|
|
19
|
|
20 ;; You should have received a copy of the GNU General Public License
|
17071
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
23 ;; Boston, MA 02111-1307, USA.
|
17052
|
24
|
|
25 ;;; Code:
|
|
26
|
17842
|
27 ;; Set standard REGISTRY property of charset to find an appropriate
|
17052
|
28 ;; font for each charset. This is used to generate a font name in a
|
|
29 ;; fontset. If the value contains a character `-', the string before
|
23196
|
30 ;; that is embedded in `CHARSET_REGISTRY' field, and the string after
|
|
31 ;; that is embedded in `CHARSET_ENCODING' field. If the value does not
|
|
32 ;; contain `-', the whole string is embedded in `CHARSET_REGISTRY'
|
|
33 ;; field, and a wild card character `*' is embedded in
|
17052
|
34 ;; `CHARSET_ENCODING' field.
|
|
35
|
|
36 (defvar x-charset-registries
|
|
37 '((ascii . "ISO8859-1")
|
|
38 (latin-iso8859-1 . "ISO8859-1")
|
|
39 (latin-iso8859-2 . "ISO8859-2")
|
|
40 (latin-iso8859-3 . "ISO8859-3")
|
|
41 (latin-iso8859-4 . "ISO8859-4")
|
|
42 (thai-tis620 . "TIS620")
|
|
43 (greek-iso8859-7 . "ISO8859-7")
|
|
44 (arabic-iso8859-6 . "ISO8859-6")
|
|
45 (hebrew-iso8859-8 . "ISO8859-8")
|
|
46 (katakana-jisx0201 . "JISX0201")
|
|
47 (latin-jisx0201 . "JISX0201")
|
|
48 (cyrillic-iso8859-5 . "ISO8859-5")
|
|
49 (latin-iso8859-9 . "ISO8859-9")
|
|
50 (japanese-jisx0208-1978 . "JISX0208.1978")
|
|
51 (chinese-gb2312 . "GB2312")
|
|
52 (japanese-jisx0208 . "JISX0208.1983")
|
|
53 (korean-ksc5601 . "KSC5601")
|
|
54 (japanese-jisx0212 . "JISX0212")
|
|
55 (chinese-cns11643-1 . "CNS11643.1992-1")
|
|
56 (chinese-cns11643-2 . "CNS11643.1992-2")
|
|
57 (chinese-cns11643-3 . "CNS11643.1992-3")
|
|
58 (chinese-cns11643-4 . "CNS11643.1992-4")
|
|
59 (chinese-cns11643-5 . "CNS11643.1992-5")
|
|
60 (chinese-cns11643-6 . "CNS11643.1992-6")
|
|
61 (chinese-cns11643-7 . "CNS11643.1992-7")
|
|
62 (chinese-big5-1 . "Big5")
|
|
63 (chinese-big5-2 . "Big5")
|
|
64 (chinese-sisheng . "sisheng_cwnn")
|
|
65 (vietnamese-viscii-lower . "VISCII1.1")
|
|
66 (vietnamese-viscii-upper . "VISCII1.1")
|
|
67 (arabic-digit . "MuleArabic-0")
|
|
68 (arabic-1-column . "MuleArabic-1")
|
|
69 (arabic-2-column . "MuleArabic-2")
|
|
70 (ipa . "MuleIPA")
|
17177
|
71 (ethiopic . "Ethiopic-Unicode")
|
17052
|
72 (ascii-right-to-left . "ISO8859-1")
|
|
73 (indian-is13194 . "IS13194-Devanagari")
|
|
74 (indian-2-column . "MuleIndian-2")
|
|
75 (indian-1-column . "MuleIndian-1")
|
18350
|
76 (lao . "MuleLao-1")
|
|
77 (tibetan . "MuleTibetan-0")
|
|
78 (tibetan-1-column . "MuleTibetan-1")
|
17295
|
79 ))
|
17052
|
80
|
|
81 (let ((l x-charset-registries))
|
|
82 (while l
|
17339
|
83 (condition-case nil
|
|
84 (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
|
|
85 (error nil))
|
17052
|
86 (setq l (cdr l))))
|
|
87
|
|
88 ;; Set arguments in `font-encoding-alist' (which see).
|
|
89 (defun set-font-encoding (pattern charset encoding)
|
|
90 (let ((slot (assoc pattern font-encoding-alist)))
|
|
91 (if slot
|
|
92 (let ((place (assq charset (cdr slot))))
|
|
93 (if place
|
|
94 (setcdr place encoding)
|
|
95 (setcdr slot (cons (cons charset encoding) (cdr slot)))))
|
|
96 (setq font-encoding-alist
|
|
97 (cons (list pattern (cons charset encoding)) font-encoding-alist)))
|
|
98 ))
|
|
99
|
|
100 (set-font-encoding "ISO8859-1" 'ascii 0)
|
|
101 (set-font-encoding "JISX0201" 'latin-jisx0201 0)
|
|
102
|
|
103 ;; Setting for suppressing XLoadQueryFont on big fonts.
|
|
104 (setq x-pixel-size-width-font-regexp
|
|
105 "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
|
|
106
|
22161
|
107 (defvar x-font-name-charset-alist
|
|
108 '(("iso8859-1" ascii latin-iso8859-1)
|
|
109 ("iso8859-2" ascii latin-iso8859-2)
|
|
110 ("iso8859-3" ascii latin-iso8859-3)
|
|
111 ("iso8859-4" ascii latin-iso8859-4)
|
|
112 ("iso8859-5" ascii cyrillic-iso8859-5)
|
|
113 ("iso8859-6" ascii arabic-iso8859-6)
|
|
114 ("iso8859-7" ascii greek-iso8859-7)
|
|
115 ("iso8859-8" ascii hebrew-iso8859-8)
|
|
116 ("tis620" ascii thai-tis620)
|
|
117 ("koi8" ascii cyrillic-iso8859-5)
|
|
118 ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
|
|
119 ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower)
|
|
120 ("mulelao-1" ascii lao))
|
|
121 "Alist of font names vs list of charsets the font can display.
|
|
122
|
|
123 When a font name which matches some element of this alist is given as
|
|
124 `-fn' command line argument or is specified by X resource, a fontset
|
|
125 which uses the specified font for the corresponding charsets are
|
|
126 created and used for the initial frame.")
|
|
127
|
17052
|
128 ;;; XLFD (X Logical Font Description) format handler.
|
|
129
|
|
130 ;; Define XLFD's field index numbers. ; field name
|
|
131 (defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY
|
|
132 (defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME
|
|
133 (defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME
|
|
134 (defconst xlfd-regexp-slant-subnum 3) ; SLANT
|
|
135 (defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME
|
|
136 (defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME
|
|
137 (defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE
|
|
138 (defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE
|
|
139 (defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X
|
|
140 (defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y
|
|
141 (defconst xlfd-regexp-spacing-subnum 10) ; SPACING
|
|
142 (defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH
|
|
143 (defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY
|
|
144 (defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING
|
|
145
|
|
146 ;; Regular expression matching against a fontname which conforms to
|
|
147 ;; XLFD (X Logical Font Description). All fields in XLFD should be
|
|
148 ;; not be omitted (but can be a wild card) to be matched.
|
|
149 (defconst xlfd-tight-regexp
|
|
150 "^\
|
|
151 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
|
|
152 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
|
|
153 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")
|
|
154
|
|
155 ;; List of field numbers of XLFD whose values are numeric.
|
|
156 (defconst xlfd-regexp-numeric-subnums
|
|
157 (list xlfd-regexp-pixelsize-subnum ;6
|
|
158 xlfd-regexp-pointsize-subnum ;7
|
|
159 xlfd-regexp-resx-subnum ;8
|
|
160 xlfd-regexp-resy-subnum ;9
|
|
161 xlfd-regexp-avgwidth-subnum ;11
|
|
162 ))
|
|
163
|
|
164 (defun x-decompose-font-name (pattern)
|
|
165 "Decompose PATTERN into XLFD's fields and return vector of the fields.
|
|
166 The length of the vector is 14.
|
|
167
|
|
168 If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
|
|
169 X server and use the information of the full name to decompose
|
|
170 PATTERN. If no full XLFD name is gotten, return nil."
|
|
171 (let (xlfd-fields fontname)
|
|
172 (if (string-match xlfd-tight-regexp pattern)
|
|
173 (let ((i 0))
|
|
174 (setq xlfd-fields (make-vector 14 nil))
|
|
175 (while (< i 14)
|
|
176 (aset xlfd-fields i (match-string (1+ i) pattern))
|
|
177 (setq i (1+ i)))
|
|
178 xlfd-fields)
|
|
179 (setq fontname (condition-case nil
|
|
180 (x-resolve-font-name pattern)
|
|
181 (error)))
|
|
182 (if (and fontname
|
|
183 (string-match xlfd-tight-regexp fontname))
|
23890
|
184 ;; We get a full XLFD name.
|
17052
|
185 (let ((len (length pattern))
|
|
186 (i 0)
|
|
187 l)
|
23890
|
188 ;; Setup xlfd-fields by the full XLFD name. Each element
|
|
189 ;; should be a cons of matched index and matched string.
|
17052
|
190 (setq xlfd-fields (make-vector 14 nil))
|
|
191 (while (< i 14)
|
|
192 (aset xlfd-fields i
|
|
193 (cons (match-beginning (1+ i))
|
|
194 (match-string (1+ i) fontname)))
|
|
195 (setq i (1+ i)))
|
23890
|
196
|
|
197 ;; Replace wild cards in PATTERN by regexp codes.
|
17052
|
198 (setq i 0)
|
|
199 (while (< i len)
|
|
200 (let ((ch (aref pattern i)))
|
|
201 (if (= ch ??)
|
|
202 (setq pattern (concat (substring pattern 0 i)
|
|
203 "\\(.\\)"
|
|
204 (substring pattern (1+ i)))
|
|
205 len (+ len 4)
|
|
206 i (+ i 4))
|
|
207 (if (= ch ?*)
|
|
208 (setq pattern (concat (substring pattern 0 i)
|
|
209 "\\(.*\\)"
|
|
210 (substring pattern (1+ i)))
|
|
211 len (+ len 5)
|
|
212 i (+ i 5))
|
|
213 (setq i (1+ i))))))
|
23890
|
214
|
|
215 ;; Set each element of xlfd-fields to proper strings.
|
|
216 (if (string-match pattern fontname)
|
|
217 ;; The regular expression PATTERN matchs the full XLFD
|
|
218 ;; name. Set elements that correspond to a wild card
|
|
219 ;; in PATTERN to "*", set the other elements to the
|
|
220 ;; exact strings in PATTERN.
|
|
221 (let ((l (cdr (cdr (match-data)))))
|
|
222 (setq i 0)
|
|
223 (while (< i 14)
|
|
224 (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
|
|
225 (progn
|
|
226 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
|
|
227 (setq i (1+ i)))
|
|
228 (if (< (car (aref xlfd-fields i)) (car (cdr l)))
|
|
229 (progn
|
|
230 (aset xlfd-fields i "*")
|
|
231 (setq i (1+ i)))
|
|
232 (setq l (cdr (cdr l)))))))
|
|
233 ;; Set each element of xlfd-fields to the exact string
|
|
234 ;; in the corresonding fields in full XLFD name.
|
|
235 (setq i 0)
|
|
236 (while (< i 14)
|
|
237 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
|
|
238 (setq i (1+ i))))
|
17052
|
239 xlfd-fields)))))
|
|
240
|
17177
|
241 ;; Replace consecutive wild-cards (`*') in NAME to one.
|
|
242 ;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1"
|
|
243 (defsubst x-reduce-font-name (name)
|
|
244 (while (string-match "-\\*-\\(\\*-\\)+" name)
|
|
245 (setq name (replace-match "-*-" t t name)))
|
|
246 name)
|
|
247
|
22449
|
248 (defun x-compose-font-name (fields &optional reduce)
|
17052
|
249 "Compose X's fontname from FIELDS.
|
22449
|
250 FIELDS is a vector of XLFD fields, the length 14.
|
17177
|
251 If a field is nil, wild-card letter `*' is embedded.
|
|
252 Optional argument REDUCE non-nil means consecutive wild-cards are
|
|
253 reduced to be one."
|
|
254 (let ((name
|
22449
|
255 (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-"))))
|
17177
|
256 (if reduce
|
|
257 (x-reduce-font-name name)
|
|
258 name)))
|
17052
|
259
|
19456
|
260 (defun register-alternate-fontnames (fontname)
|
|
261 "Register alternate fontnames for FONTNAME in `alternate-fontname-alist'.
|
22161
|
262 When Emacs fails to open FONTNAME, it tries to open an alternate font
|
19456
|
263 registered in the variable `alternate-fontname-alist' (which see).
|
|
264
|
|
265 For FONTNAME, the following three alternate fontnames are registered:
|
|
266 fontname which ignores style specification of FONTNAME,
|
|
267 fontname which ignores size specification of FONTNAME,
|
22161
|
268 fontname which ignores both style and size specification of FONTNAME.
|
|
269 Emacs tries to open fonts in this order."
|
19456
|
270 (unless (assoc fontname alternate-fontname-alist)
|
|
271 (let ((xlfd-fields (x-decompose-font-name fontname))
|
|
272 style-ignored size-ignored both-ignored)
|
|
273 (when xlfd-fields
|
|
274 (aset xlfd-fields xlfd-regexp-foundry-subnum nil)
|
|
275 (aset xlfd-fields xlfd-regexp-family-subnum nil)
|
|
276
|
|
277 (let ((temp (copy-sequence xlfd-fields)))
|
|
278 (aset temp xlfd-regexp-weight-subnum nil)
|
|
279 (aset temp xlfd-regexp-slant-subnum nil)
|
|
280 (aset temp xlfd-regexp-swidth-subnum nil)
|
|
281 (aset temp xlfd-regexp-adstyle-subnum nil)
|
|
282 (setq style-ignored (x-compose-font-name temp t)))
|
|
283
|
|
284 (aset xlfd-fields xlfd-regexp-pixelsize-subnum nil)
|
|
285 (aset xlfd-fields xlfd-regexp-pointsize-subnum nil)
|
|
286 (aset xlfd-fields xlfd-regexp-resx-subnum nil)
|
|
287 (aset xlfd-fields xlfd-regexp-resy-subnum nil)
|
|
288 (aset xlfd-fields xlfd-regexp-spacing-subnum nil)
|
|
289 (aset xlfd-fields xlfd-regexp-avgwidth-subnum nil)
|
|
290 (setq size-ignored (x-compose-font-name xlfd-fields t))
|
|
291
|
|
292 (aset xlfd-fields xlfd-regexp-weight-subnum nil)
|
|
293 (aset xlfd-fields xlfd-regexp-slant-subnum nil)
|
|
294 (aset xlfd-fields xlfd-regexp-swidth-subnum nil)
|
|
295 (aset xlfd-fields xlfd-regexp-adstyle-subnum nil)
|
|
296 (setq both-ignored (x-compose-font-name xlfd-fields t))
|
|
297
|
|
298 (setq alternate-fontname-alist
|
|
299 (cons (list fontname style-ignored size-ignored both-ignored)
|
|
300 alternate-fontname-alist))))))
|
|
301
|
23205
|
302 ;; Just to avoid compiler waring. The gloval value is never used.
|
|
303 (defvar resolved-ascii-font nil)
|
|
304
|
17052
|
305 (defun x-complement-fontset-spec (xlfd-fields fontlist)
|
|
306 "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it.
|
|
307 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
|
22161
|
308 FONTLIST is an alist of charsets vs the corresponding font names.
|
17052
|
309
|
22161
|
310 Font names for charsets not listed in FONTLIST are generated from
|
18350
|
311 XLFD-FIELDS and a property of x-charset-registry of each charset
|
23205
|
312 automatically.
|
|
313
|
|
314 By side effect, this sets `resolved-ascii-font' to the resolved name
|
|
315 of ASCII font."
|
22449
|
316 (let ((charsets charset-list)
|
|
317 (xlfd-fields-non-ascii (copy-sequence xlfd-fields))
|
|
318 (new-fontlist nil))
|
|
319 (aset xlfd-fields-non-ascii xlfd-regexp-foundry-subnum nil)
|
|
320 (aset xlfd-fields-non-ascii xlfd-regexp-family-subnum nil)
|
|
321 (aset xlfd-fields-non-ascii xlfd-regexp-adstyle-subnum nil)
|
|
322 (aset xlfd-fields-non-ascii xlfd-regexp-avgwidth-subnum nil)
|
17052
|
323 (while charsets
|
|
324 (let ((charset (car charsets)))
|
19456
|
325 (unless (assq charset fontlist)
|
22449
|
326 (let ((registry (get-charset-property charset 'x-charset-registry))
|
22161
|
327 registry-val encoding-val fontname)
|
19456
|
328 (if (string-match "-" registry)
|
|
329 ;; REGISTRY contains `CHARSET_ENCODING' field.
|
|
330 (setq registry-val (substring registry 0 (match-beginning 0))
|
|
331 encoding-val (substring registry (match-end 0)))
|
|
332 (setq registry-val (concat registry "*")
|
|
333 encoding-val "*"))
|
22449
|
334 (let ((xlfd (if (eq charset 'ascii) xlfd-fields
|
|
335 xlfd-fields-non-ascii)))
|
|
336 (aset xlfd xlfd-regexp-registry-subnum registry-val)
|
|
337 (aset xlfd xlfd-regexp-encoding-subnum encoding-val)
|
|
338 (setq fontname (downcase (x-compose-font-name xlfd))))
|
|
339 (setq new-fontlist (cons (cons charset fontname) new-fontlist))
|
19456
|
340 (register-alternate-fontnames fontname))))
|
22449
|
341 (setq charsets (cdr charsets)))
|
18350
|
342
|
22720
|
343 ;; Be sure that ASCII font is available.
|
22449
|
344 (let ((slot (or (assq 'ascii fontlist) (assq 'ascii new-fontlist)))
|
|
345 ascii-font)
|
23161
|
346 (setq ascii-font (condition-case nil
|
|
347 (x-resolve-font-name (cdr slot))
|
|
348 (error nil)))
|
22449
|
349 (if ascii-font
|
|
350 (let ((l x-font-name-charset-alist))
|
|
351 ;; If the ASCII font can also be used for another
|
|
352 ;; charsets, use that font instead of what generated based
|
23196
|
353 ;; on x-charset-registry in the previous code.
|
22449
|
354 (while l
|
|
355 (if (string-match (car (car l)) ascii-font)
|
23205
|
356 (let ((charsets (cdr (car l)))
|
|
357 slot2)
|
22449
|
358 (while charsets
|
|
359 (if (and (not (eq (car charsets) 'ascii))
|
23205
|
360 (setq slot2 (assq (car charsets) new-fontlist)))
|
|
361 (setcdr slot2 (cdr slot)))
|
22449
|
362 (setq charsets (cdr charsets)))
|
|
363 (setq l nil))
|
|
364 (setq l (cdr l))))
|
23205
|
365 (setq resolved-ascii-font ascii-font)
|
22449
|
366 (append fontlist new-fontlist))))))
|
17052
|
367
|
19049
|
368 (defun fontset-name-p (fontset)
|
|
369 "Return non-nil if FONTSET is valid as fontset name.
|
|
370 A valid fontset name should conform to XLFD (X Logical Font Description)
|
|
371 with \"fontset\" in `<CHARSET_REGISTRY> field."
|
|
372 (and (string-match xlfd-tight-regexp fontset)
|
|
373 (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset)
|
|
374 "fontset")))
|
|
375
|
17052
|
376 ;; Return a list to be appended to `x-fixed-font-alist' when
|
|
377 ;; `mouse-set-font' is called.
|
|
378 (defun generate-fontset-menu ()
|
|
379 (let ((fontsets global-fontset-alist)
|
|
380 fontset-name
|
|
381 l)
|
|
382 (while fontsets
|
|
383 (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets))
|
17755
|
384 (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
|
24160
|
385 (cons "Fontset"
|
|
386 (sort l (function (lambda (x y) (string< (car x) (car y))))))))
|
17052
|
387
|
|
388 (defun fontset-plain-name (fontset)
|
|
389 "Return a plain and descriptive name of FONTSET."
|
17755
|
390 (if (not (setq fontset (query-fontset fontset)))
|
|
391 (error "Invalid fontset: %s" fontset))
|
17052
|
392 (let ((xlfd-fields (x-decompose-font-name fontset)))
|
|
393 (if xlfd-fields
|
|
394 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
|
|
395 (slant (aref xlfd-fields xlfd-regexp-slant-subnum))
|
|
396 (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
|
|
397 (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
|
17755
|
398 (charset (aref xlfd-fields xlfd-regexp-registry-subnum))
|
|
399 (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum))
|
17052
|
400 name)
|
17755
|
401 (if (not (string= "fontset" charset))
|
17052
|
402 fontset
|
17755
|
403 (if (> (string-to-int size) 0)
|
|
404 (setq name (format "%s: %s-dot" nickname size))
|
|
405 (setq name nickname))
|
|
406 (cond ((string-match "^medium$" weight)
|
|
407 (setq name (concat name " " "medium")))
|
|
408 ((string-match "^bold$\\|^demibold$" weight)
|
|
409 (setq name (concat name " " weight))))
|
|
410 (cond ((string-match "^i$" slant)
|
|
411 (setq name (concat name " " "italic")))
|
|
412 ((string-match "^o$" slant)
|
|
413 (setq name (concat name " " "slant")))
|
|
414 ((string-match "^ri$" slant)
|
|
415 (setq name (concat name " " "reverse italic")))
|
|
416 ((string-match "^ro$" slant)
|
|
417 (setq name (concat name " " "reverse slant"))))
|
17052
|
418 name))
|
|
419 fontset)))
|
|
420
|
19771
|
421 (defvar uninstantiated-fontset-alist nil
|
|
422 "Alist of fontset names vs. information for instantiating them.
|
22161
|
423 Each element has the form (FONTSET STYLE FONTLIST), where
|
19771
|
424 FONTSET is a name of fontset not yet instantiated.
|
19049
|
425 STYLE is a style of FONTSET, one of the followings:
|
|
426 bold, demobold, italic, oblique,
|
|
427 bold-italic, demibold-italic, bold-oblique, demibold-oblique.
|
22161
|
428 FONTLIST is an alist of charsets vs font names to be used in FONSET.")
|
|
429
|
|
430 (defconst x-style-funcs-alist
|
22449
|
431 `((bold . x-make-font-bold)
|
|
432 (demibold . x-make-font-demibold)
|
|
433 (italic . x-make-font-italic)
|
|
434 (oblique . x-make-font-oblique)
|
|
435 (bold-italic . x-make-font-bold-italic)
|
|
436 (demibold-italic
|
22510
|
437 . ,(function (lambda (x)
|
|
438 (let ((y (x-make-font-demibold x)))
|
|
439 (and y (x-make-font-italic y))))))
|
|
440 (demibold-oblique
|
|
441 . ,(function (lambda (x)
|
|
442 (let ((y (x-make-font-demibold x)))
|
|
443 (and y (x-make-font-oblique y))))))
|
|
444 (bold-oblique
|
|
445 . ,(function (lambda (x)
|
|
446 (let ((y (x-make-font-bold x)))
|
|
447 (and y (x-make-font-oblique y)))))))
|
|
448 "Alist of font style vs function to generate a X font name of the style.
|
|
449 The function is called with one argument, a font name.")
|
|
450
|
|
451 (defcustom fontset-default-styles '(bold italic bold-italic)
|
|
452 "List of alternative styles to create for a fontset.
|
|
453 Valid elements include `bold', `demibold'; `italic', `oblique';
|
|
454 and combinations of one from each group,
|
|
455 such as `bold-italic' and `demibold-oblique'."
|
|
456 :group 'faces
|
22601
|
457 :type '(set (const bold) (const demibold) (const italic) (const oblique)
|
|
458 (const bold-italic) (const bold-oblique) (const demibold-italic)
|
|
459 (const demibold-oblique)))
|
22510
|
460
|
22449
|
461 (defun x-modify-font-name (fontname style)
|
|
462 "Substitute style specification part of FONTNAME for STYLE.
|
|
463 STYLE should be listed in the variable `x-style-funcs-alist'."
|
|
464 (let ((func (cdr (assq style x-style-funcs-alist))))
|
|
465 (if func
|
|
466 (funcall func fontname))))
|
19049
|
467
|
22128
|
468 ;;;###autoload
|
22161
|
469 (defun create-fontset-from-fontset-spec (fontset-spec
|
22449
|
470 &optional style-variant noerror)
|
17052
|
471 "Create a fontset from fontset specification string FONTSET-SPEC.
|
|
472 FONTSET-SPEC is a string of the format:
|
|
473 FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
|
17755
|
474 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
|
22449
|
475
|
|
476 Optional 2nd argument STYLE-VARIANT is a list of font styles
|
|
477 \(e.g. bold, italic) or the symbol t to specify all available styles.
|
|
478 If this argument is specified, fontsets which differs from
|
|
479 FONTSET-NAME in styles are also created. An element of STYLE-VARIANT
|
|
480 may be cons of style and a font name. In this case, the style variant
|
|
481 fontset uses the font for ASCII character set.
|
|
482
|
18719
|
483 If this function attempts to create already existing fontset, error is
|
22672
|
484 signaled unless the optional 3rd argument NOERROR is non-nil.
|
|
485
|
|
486 It returns a name of the created fontset."
|
17755
|
487 (if (not (string-match "^[^,]+" fontset-spec))
|
|
488 (error "Invalid fontset spec: %s" fontset-spec))
|
|
489 (let ((idx (match-end 0))
|
|
490 (name (match-string 0 fontset-spec))
|
22618
|
491 fontlist full-fontlist ascii-font resolved-ascii-font charset)
|
22161
|
492 (if (query-fontset name)
|
|
493 (or noerror
|
23655
|
494 (error "Fontset \"%s\" already exists" name))
|
22161
|
495 ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
|
|
496 (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
|
|
497 (setq idx (match-end 0))
|
|
498 (setq charset (intern (match-string 1 fontset-spec)))
|
|
499 (if (charsetp charset)
|
|
500 (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
|
|
501 fontlist))))
|
22449
|
502 ;; Remember the specified ASCII font name now because it will be
|
|
503 ;; replaced by resolved font name by x-complement-fontset-spec.
|
|
504 (setq ascii-font (cdr (assq 'ascii fontlist)))
|
19049
|
505
|
22161
|
506 ;; If NAME conforms to XLFD, complement FONTLIST for charsets
|
|
507 ;; which are not specified in FONTSET-SPEC.
|
22449
|
508 (let ((fields (x-decompose-font-name name)))
|
|
509 (if fields
|
|
510 (setq full-fontlist (x-complement-fontset-spec fields fontlist))))
|
22161
|
511
|
22449
|
512 (when full-fontlist
|
|
513 ;; Create the fontset.
|
|
514 (new-fontset name full-fontlist)
|
|
515
|
|
516 ;; Define aliases: short name (if appropriate) and ASCII font name.
|
|
517 (if (and (string-match "fontset-.*$" name)
|
|
518 (not (assoc name fontset-alias-alist)))
|
|
519 (let ((alias (match-string 0 name)))
|
|
520 (or (rassoc alias fontset-alias-alist)
|
|
521 (setq fontset-alias-alist
|
|
522 (cons (cons name alias) fontset-alias-alist)))))
|
24609
|
523 (or (rassoc resolved-ascii-font fontset-alias-alist)
|
|
524 (setq fontset-alias-alist
|
|
525 (cons (cons name resolved-ascii-font)
|
|
526 fontset-alias-alist)))
|
22618
|
527 (or (equal ascii-font resolved-ascii-font)
|
24609
|
528 (rassoc ascii-font fontset-alias-alist)
|
22618
|
529 (setq fontset-alias-alist
|
|
530 (cons (cons name ascii-font)
|
|
531 fontset-alias-alist)))
|
22449
|
532
|
|
533 ;; At last, handle style variants.
|
|
534 (if (eq style-variant t)
|
22510
|
535 (setq style-variant fontset-default-styles))
|
22161
|
536
|
22449
|
537 (if style-variant
|
|
538 ;; Generate fontset names of style variants and set them
|
|
539 ;; in uninstantiated-fontset-alist.
|
|
540 (let* (nonascii-fontlist
|
|
541 new-name new-ascii-font style font)
|
|
542 (if ascii-font
|
|
543 (setq nonascii-fontlist (delete (cons 'ascii ascii-font)
|
|
544 (copy-sequence fontlist)))
|
|
545 (setq ascii-font (cdr (assq 'ascii full-fontlist))
|
|
546 nonascii-fontlist fontlist))
|
|
547 (while style-variant
|
|
548 (setq style (car style-variant))
|
|
549 (if (symbolp style)
|
|
550 (setq font nil)
|
|
551 (setq font (cdr style)
|
|
552 style (car style)))
|
|
553 (setq new-name (x-modify-font-name name style))
|
|
554 (when new-name
|
|
555 ;; Modify ASCII font name for the style...
|
|
556 (setq new-ascii-font
|
22618
|
557 (or font
|
|
558 (x-modify-font-name resolved-ascii-font style)))
|
22449
|
559 ;; but leave fonts for the other charsets unmodified
|
23196
|
560 ;; for the moment. They are modified for the style
|
22449
|
561 ;; in instantiate-fontset.
|
|
562 (setq uninstantiated-fontset-alist
|
|
563 (cons (list new-name
|
|
564 style
|
|
565 (cons (cons 'ascii new-ascii-font)
|
|
566 nonascii-fontlist))
|
|
567 uninstantiated-fontset-alist))
|
24609
|
568 (or (rassoc new-ascii-font fontset-alias-alist)
|
|
569 (setq fontset-alias-alist
|
|
570 (cons (cons new-name new-ascii-font)
|
|
571 fontset-alias-alist))))
|
22672
|
572 (setq style-variant (cdr style-variant)))))))
|
|
573 name))
|
|
574
|
|
575 (defun create-fontset-from-ascii-font (font &optional resolved-font
|
|
576 fontset-name)
|
|
577 "Create a fontset from an ASCII font FONT.
|
|
578
|
|
579 Optional 1st arg RESOLVED-FONT is a resolved name of FONT. If
|
|
580 omitted, x-resolve-font-name is called to get the resolved name. At
|
22720
|
581 this time, if FONT is not available, error is signaled.
|
22672
|
582
|
|
583 Optional 2nd arg FONTSET-NAME is a string to be used in
|
|
584 `<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted,
|
|
585 an appropriate name is generated automatically.
|
|
586
|
|
587 Style variants of the fontset is created too. Font names in the
|
23196
|
588 variants are generated automatically from FONT unless X resources
|
|
589 XXX.attributeFont explicitly specify them.
|
22672
|
590
|
|
591 It returns a name of the created fontset."
|
|
592 (or resolved-font
|
|
593 (setq resolved-font (x-resolve-font-name font)))
|
|
594 (let* ((faces (copy-sequence fontset-default-styles))
|
|
595 (styles faces)
|
|
596 (xlfd (x-decompose-font-name font))
|
|
597 (resolved-xlfd (x-decompose-font-name resolved-font))
|
|
598 face face-font fontset fontset-spec)
|
|
599 (while faces
|
|
600 (setq face (car faces))
|
|
601 (setq face-font (x-get-resource (concat (symbol-name face)
|
|
602 ".attributeFont")
|
|
603 "Face.AttributeFont"))
|
|
604 (if face-font
|
|
605 (setcar faces (cons face face-font)))
|
|
606 (setq faces (cdr faces)))
|
|
607 (aset xlfd xlfd-regexp-foundry-subnum nil)
|
|
608 (aset xlfd xlfd-regexp-family-subnum nil)
|
|
609 (aset xlfd xlfd-regexp-registry-subnum "fontset")
|
|
610 (or fontset-name
|
|
611 (setq fontset-name
|
|
612 (format "%s_%s_%s"
|
|
613 (aref resolved-xlfd xlfd-regexp-registry-subnum)
|
|
614 (aref resolved-xlfd xlfd-regexp-encoding-subnum)
|
|
615 (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
|
|
616 (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
|
|
617 ;; The fontset name should have concrete values in weight and
|
|
618 ;; slant field.
|
|
619 (let ((weight (aref xlfd xlfd-regexp-weight-subnum))
|
|
620 (slant (aref xlfd xlfd-regexp-slant-subnum)))
|
|
621 (if (or (not weight) (string-match "[*?]*" weight))
|
|
622 (aset xlfd xlfd-regexp-weight-subnum
|
|
623 (aref resolved-xlfd xlfd-regexp-weight-subnum)))
|
|
624 (if (or (not slant) (string-match "[*?]*" slant))
|
|
625 (aset xlfd xlfd-regexp-slant-subnum
|
|
626 (aref resolved-xlfd xlfd-regexp-slant-subnum))))
|
|
627 (setq fontset (x-compose-font-name xlfd))
|
|
628 (or (query-fontset fontset)
|
|
629 (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)
|
|
630 styles))))
|
17052
|
631
|
19771
|
632 (defun instantiate-fontset (fontset)
|
23196
|
633 "Make FONTSET be ready to use.
|
22161
|
634 FONTSET should be in the variable `uninstantiated-fontset-alist' in advance.
|
19049
|
635 Return FONTSET if it is created successfully, else return nil."
|
19771
|
636 (let ((fontset-data (assoc fontset uninstantiated-fontset-alist)))
|
22449
|
637 (when fontset-data
|
|
638 (setq uninstantiated-fontset-alist
|
|
639 (delete fontset-data uninstantiated-fontset-alist))
|
22161
|
640
|
22449
|
641 (let* ((fields (x-decompose-font-name fontset))
|
|
642 (style (nth 1 fontset-data))
|
|
643 (fontlist (x-complement-fontset-spec fields (nth 2 fontset-data)))
|
|
644 (font (cdr (assq 'ascii fontlist))))
|
|
645 ;; If ASCII font is available, instantiate this fontset.
|
19049
|
646 (when font
|
22161
|
647 (let ((new-fontlist (list (cons 'ascii font))))
|
22449
|
648 ;; Fonts for non-ascii charsets should be modified for
|
|
649 ;; this style now.
|
22161
|
650 (while fontlist
|
|
651 (setq font (cdr (car fontlist)))
|
|
652 (or (eq (car (car fontlist)) 'ascii)
|
22449
|
653 (setq new-fontlist
|
|
654 (cons (cons (car (car fontlist))
|
|
655 (x-modify-font-name font style))
|
|
656 new-fontlist)))
|
22161
|
657 (setq fontlist (cdr fontlist)))
|
22449
|
658 (new-fontset fontset new-fontlist)
|
22161
|
659 fontset))))))
|
22449
|
660
|
|
661 (defun resolve-fontset-name (pattern)
|
|
662 "Return a fontset name matching PATTERN."
|
|
663 (let ((fontset (car (rassoc pattern fontset-alias-alist))))
|
|
664 (or fontset (setq fontset pattern))
|
|
665 (if (assoc fontset uninstantiated-fontset-alist)
|
|
666 (instantiate-fontset fontset)
|
|
667 (query-fontset fontset))))
|
17052
|
668
|
17842
|
669 ;; Create standard fontset from 16 dots fonts which are the most widely
|
17989
|
670 ;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are
|
|
671 ;; specified here because FAMILY of those fonts are not "fixed" in
|
|
672 ;; many cases.
|
17842
|
673 (defvar standard-fontset-spec
|
|
674 "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
|
17052
|
675 chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
|
|
676 korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
|
|
677 chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
|
|
678 chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
|
|
679 chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
|
|
680 chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
|
|
681 chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
|
|
682 chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
|
|
683 chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
|
17842
|
684 "String of fontset spec of the standard fontset.
|
|
685 You have the biggest chance to display international characters
|
|
686 with correct glyphs by using the standard fontset.
|
17052
|
687 See the documentation of `create-fontset-from-fontset-spec' for the format.")
|
|
688
|
|
689 ;; Create fontsets from X resources of the name `fontset-N (class
|
|
690 ;; Fontset-N)' where N is integer 0, 1, ...
|
|
691 ;; The values of the resources the string of the same format as
|
17842
|
692 ;; `standard-fontset-spec'.
|
17052
|
693
|
|
694 (defun create-fontset-from-x-resource ()
|
|
695 (let ((idx 0)
|
|
696 fontset-spec)
|
|
697 (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
|
|
698 (concat "Fontset-" idx)))
|
24153
|
699 (create-fontset-from-fontset-spec fontset-spec t 'noerror)
|
17052
|
700 (setq idx (1+ idx)))))
|
|
701
|
|
702 (defsubst fontset-list ()
|
|
703 "Returns a list of all defined fontset names."
|
|
704 (mapcar 'car global-fontset-alist))
|
|
705
|
|
706 ;;
|
|
707 (provide 'fontset)
|
|
708
|
|
709 ;;; fontset.el ends here
|