Commit | Line | Data |
---|---|---|
4ed46869 KH |
1 | ;;; fontset.el --- Commands for handling fontset. |
2 | ||
fa526c4a RS |
3 | ;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN. |
4 | ;; Licensed to the Free Software Foundation. | |
4ed46869 KH |
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 | |
369314dc KH |
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. | |
4ed46869 KH |
24 | |
25 | ;;; Code: | |
26 | ||
acfb10b8 | 27 | ;; Set standard REGISTRY property of charset to find an appropriate |
4ed46869 KH |
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 | |
30 | ;; that is embeded in `CHARSET_REGISTRY' field, and the string after | |
31 | ;; that is embeded in `CHARSET_ENCODING' field. If the value does not | |
32 | ;; contain `-', the whole string is embeded in `CHARSET_REGISTRY' | |
33 | ;; field, and a wild card character `*' is embeded in | |
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") | |
441038a6 | 71 | (ethiopic . "Ethiopic-Unicode") |
4ed46869 KH |
72 | (ascii-right-to-left . "ISO8859-1") |
73 | (indian-is13194 . "IS13194-Devanagari") | |
74 | (indian-2-column . "MuleIndian-2") | |
75 | (indian-1-column . "MuleIndian-1") | |
2e18c9dd KH |
76 | (lao . "MuleLao-1") |
77 | (tibetan . "MuleTibetan-0") | |
78 | (tibetan-1-column . "MuleTibetan-1") | |
b55b5129 | 79 | )) |
4ed46869 KH |
80 | |
81 | (let ((l x-charset-registries)) | |
82 | (while l | |
2316704a RS |
83 | (condition-case nil |
84 | (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l))) | |
85 | (error nil)) | |
4ed46869 KH |
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 | ||
107 | ;;; XLFD (X Logical Font Description) format handler. | |
108 | ||
109 | ;; Define XLFD's field index numbers. ; field name | |
110 | (defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY | |
111 | (defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME | |
112 | (defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME | |
113 | (defconst xlfd-regexp-slant-subnum 3) ; SLANT | |
114 | (defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME | |
115 | (defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME | |
116 | (defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE | |
117 | (defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE | |
118 | (defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X | |
119 | (defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y | |
120 | (defconst xlfd-regexp-spacing-subnum 10) ; SPACING | |
121 | (defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH | |
122 | (defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY | |
123 | (defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING | |
124 | ||
125 | ;; Regular expression matching against a fontname which conforms to | |
126 | ;; XLFD (X Logical Font Description). All fields in XLFD should be | |
127 | ;; not be omitted (but can be a wild card) to be matched. | |
128 | (defconst xlfd-tight-regexp | |
129 | "^\ | |
130 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ | |
131 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ | |
132 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$") | |
133 | ||
134 | ;; List of field numbers of XLFD whose values are numeric. | |
135 | (defconst xlfd-regexp-numeric-subnums | |
136 | (list xlfd-regexp-pixelsize-subnum ;6 | |
137 | xlfd-regexp-pointsize-subnum ;7 | |
138 | xlfd-regexp-resx-subnum ;8 | |
139 | xlfd-regexp-resy-subnum ;9 | |
140 | xlfd-regexp-avgwidth-subnum ;11 | |
141 | )) | |
142 | ||
143 | (defun x-decompose-font-name (pattern) | |
144 | "Decompose PATTERN into XLFD's fields and return vector of the fields. | |
145 | The length of the vector is 14. | |
146 | ||
147 | If PATTERN doesn't conform to XLFD, try to get a full XLFD name from | |
148 | X server and use the information of the full name to decompose | |
149 | PATTERN. If no full XLFD name is gotten, return nil." | |
150 | (let (xlfd-fields fontname) | |
151 | (if (string-match xlfd-tight-regexp pattern) | |
152 | (let ((i 0)) | |
153 | (setq xlfd-fields (make-vector 14 nil)) | |
154 | (while (< i 14) | |
155 | (aset xlfd-fields i (match-string (1+ i) pattern)) | |
156 | (setq i (1+ i))) | |
157 | xlfd-fields) | |
158 | (setq fontname (condition-case nil | |
159 | (x-resolve-font-name pattern) | |
160 | (error))) | |
161 | (if (and fontname | |
162 | (string-match xlfd-tight-regexp fontname)) | |
163 | (let ((len (length pattern)) | |
164 | (i 0) | |
165 | l) | |
166 | (setq xlfd-fields (make-vector 14 nil)) | |
167 | (while (< i 14) | |
168 | (aset xlfd-fields i | |
169 | (cons (match-beginning (1+ i)) | |
170 | (match-string (1+ i) fontname))) | |
171 | (setq i (1+ i))) | |
172 | (setq i 0) | |
173 | (while (< i len) | |
174 | (let ((ch (aref pattern i))) | |
175 | (if (= ch ??) | |
176 | (setq pattern (concat (substring pattern 0 i) | |
177 | "\\(.\\)" | |
178 | (substring pattern (1+ i))) | |
179 | len (+ len 4) | |
180 | i (+ i 4)) | |
181 | (if (= ch ?*) | |
182 | (setq pattern (concat (substring pattern 0 i) | |
183 | "\\(.*\\)" | |
184 | (substring pattern (1+ i))) | |
185 | len (+ len 5) | |
186 | i (+ i 5)) | |
187 | (setq i (1+ i)))))) | |
188 | (string-match pattern fontname) | |
189 | (setq l (cdr (cdr (match-data)))) | |
190 | (setq i 0) | |
191 | (while (< i 14) | |
192 | (if (or (null l) (< (car (aref xlfd-fields i)) (car l))) | |
193 | (progn | |
194 | (aset xlfd-fields i (cdr (aref xlfd-fields i))) | |
195 | (setq i (1+ i))) | |
196 | (if (< (car (aref xlfd-fields i)) (car (cdr l))) | |
197 | (progn | |
494ec9bc | 198 | (aset xlfd-fields i "*") |
4ed46869 KH |
199 | (setq i (1+ i))) |
200 | (setq l (cdr (cdr l)))))) | |
201 | xlfd-fields))))) | |
202 | ||
441038a6 KH |
203 | ;; Replace consecutive wild-cards (`*') in NAME to one. |
204 | ;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1" | |
205 | (defsubst x-reduce-font-name (name) | |
206 | (while (string-match "-\\*-\\(\\*-\\)+" name) | |
207 | (setq name (replace-match "-*-" t t name))) | |
208 | name) | |
209 | ||
210 | (defun x-compose-font-name (xlfd-fields &optional reduce) | |
4ed46869 KH |
211 | "Compose X's fontname from FIELDS. |
212 | FIELDS is a vector of XLFD fields. | |
441038a6 KH |
213 | If a field is nil, wild-card letter `*' is embedded. |
214 | Optional argument REDUCE non-nil means consecutive wild-cards are | |
215 | reduced to be one." | |
216 | (let ((name | |
217 | (concat "-" (mapconcat (lambda (x) (or x "*")) xlfd-fields "-")))) | |
218 | (if reduce | |
219 | (x-reduce-font-name name) | |
220 | name))) | |
4ed46869 | 221 | |
800d3b18 KH |
222 | (defun register-alternate-fontnames (fontname) |
223 | "Register alternate fontnames for FONTNAME in `alternate-fontname-alist'. | |
224 | When Emacs fails to open FONTNAME, it tries to open alternate font | |
225 | registered in the variable `alternate-fontname-alist' (which see). | |
226 | ||
227 | For FONTNAME, the following three alternate fontnames are registered: | |
228 | fontname which ignores style specification of FONTNAME, | |
229 | fontname which ignores size specification of FONTNAME, | |
230 | fontname which ignores both style and size specification of FONTNAME." | |
231 | (unless (assoc fontname alternate-fontname-alist) | |
232 | (let ((xlfd-fields (x-decompose-font-name fontname)) | |
233 | style-ignored size-ignored both-ignored) | |
234 | (when xlfd-fields | |
235 | (aset xlfd-fields xlfd-regexp-foundry-subnum nil) | |
236 | (aset xlfd-fields xlfd-regexp-family-subnum nil) | |
237 | ||
238 | (let ((temp (copy-sequence xlfd-fields))) | |
239 | (aset temp xlfd-regexp-weight-subnum nil) | |
240 | (aset temp xlfd-regexp-slant-subnum nil) | |
241 | (aset temp xlfd-regexp-swidth-subnum nil) | |
242 | (aset temp xlfd-regexp-adstyle-subnum nil) | |
243 | (setq style-ignored (x-compose-font-name temp t))) | |
244 | ||
245 | (aset xlfd-fields xlfd-regexp-pixelsize-subnum nil) | |
246 | (aset xlfd-fields xlfd-regexp-pointsize-subnum nil) | |
247 | (aset xlfd-fields xlfd-regexp-resx-subnum nil) | |
248 | (aset xlfd-fields xlfd-regexp-resy-subnum nil) | |
249 | (aset xlfd-fields xlfd-regexp-spacing-subnum nil) | |
250 | (aset xlfd-fields xlfd-regexp-avgwidth-subnum nil) | |
251 | (setq size-ignored (x-compose-font-name xlfd-fields t)) | |
252 | ||
253 | (aset xlfd-fields xlfd-regexp-weight-subnum nil) | |
254 | (aset xlfd-fields xlfd-regexp-slant-subnum nil) | |
255 | (aset xlfd-fields xlfd-regexp-swidth-subnum nil) | |
256 | (aset xlfd-fields xlfd-regexp-adstyle-subnum nil) | |
257 | (setq both-ignored (x-compose-font-name xlfd-fields t)) | |
258 | ||
259 | (setq alternate-fontname-alist | |
260 | (cons (list fontname style-ignored size-ignored both-ignored) | |
261 | alternate-fontname-alist)))))) | |
262 | ||
4ed46869 KH |
263 | (defun x-complement-fontset-spec (xlfd-fields fontlist) |
264 | "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it. | |
265 | XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields. | |
266 | FONTLIST is an alist of cons of charset and fontname. | |
267 | ||
268 | Fontnames for charsets not listed in FONTLIST are generated from | |
2e18c9dd | 269 | XLFD-FIELDS and a property of x-charset-registry of each charset |
4ed46869 | 270 | automatically." |
800d3b18 | 271 | (let ((charsets charset-list)) |
4ed46869 KH |
272 | (while charsets |
273 | (let ((charset (car charsets))) | |
800d3b18 KH |
274 | (unless (assq charset fontlist) |
275 | (let ((registry (get-charset-property charset | |
276 | 'x-charset-registry)) | |
277 | registry-val encoding-val fontname loose-fontname) | |
278 | (if (string-match "-" registry) | |
279 | ;; REGISTRY contains `CHARSET_ENCODING' field. | |
280 | (setq registry-val (substring registry 0 (match-beginning 0)) | |
281 | encoding-val (substring registry (match-end 0))) | |
282 | (setq registry-val (concat registry "*") | |
283 | encoding-val "*")) | |
284 | (aset xlfd-fields xlfd-regexp-registry-subnum registry-val) | |
285 | (aset xlfd-fields xlfd-regexp-encoding-subnum encoding-val) | |
286 | (setq fontname (downcase (x-compose-font-name xlfd-fields))) | |
287 | (setq fontlist (cons (cons charset fontname) fontlist)) | |
288 | (register-alternate-fontnames fontname)))) | |
4ed46869 | 289 | (setq charsets (cdr charsets)))) |
2e18c9dd KH |
290 | |
291 | ;; Here's a trick for the charset latin-iso8859-1. If font for | |
292 | ;; ascii also contains Latin-1 characters, use it also for | |
293 | ;; latin-iso8859-1. This prevent loading a font for latin-iso8859-1 | |
294 | ;; by a different name. | |
295 | (if (string-match (cdr (assq 'latin-iso8859-1 x-charset-registries)) | |
296 | (cdr (assq 'ascii fontlist))) | |
297 | (setcdr (assq 'latin-iso8859-1 fontlist) (cdr (assq 'ascii fontlist)))) | |
4ed46869 KH |
298 | fontlist) |
299 | ||
35d4066a KH |
300 | (defun fontset-name-p (fontset) |
301 | "Return non-nil if FONTSET is valid as fontset name. | |
302 | A valid fontset name should conform to XLFD (X Logical Font Description) | |
303 | with \"fontset\" in `<CHARSET_REGISTRY> field." | |
304 | (and (string-match xlfd-tight-regexp fontset) | |
305 | (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset) | |
306 | "fontset"))) | |
307 | ||
4ed46869 KH |
308 | ;; Return a list to be appended to `x-fixed-font-alist' when |
309 | ;; `mouse-set-font' is called. | |
310 | (defun generate-fontset-menu () | |
311 | (let ((fontsets global-fontset-alist) | |
312 | fontset-name | |
313 | l) | |
314 | (while fontsets | |
315 | (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets)) | |
494ec9bc | 316 | (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l))) |
4ed46869 KH |
317 | (cons "Fontset" l))) |
318 | ||
319 | (defun fontset-plain-name (fontset) | |
320 | "Return a plain and descriptive name of FONTSET." | |
494ec9bc KH |
321 | (if (not (setq fontset (query-fontset fontset))) |
322 | (error "Invalid fontset: %s" fontset)) | |
4ed46869 KH |
323 | (let ((xlfd-fields (x-decompose-font-name fontset))) |
324 | (if xlfd-fields | |
325 | (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum)) | |
326 | (slant (aref xlfd-fields xlfd-regexp-slant-subnum)) | |
327 | (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum)) | |
328 | (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum)) | |
494ec9bc KH |
329 | (charset (aref xlfd-fields xlfd-regexp-registry-subnum)) |
330 | (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum)) | |
4ed46869 | 331 | name) |
494ec9bc | 332 | (if (not (string= "fontset" charset)) |
4ed46869 | 333 | fontset |
494ec9bc KH |
334 | (if (> (string-to-int size) 0) |
335 | (setq name (format "%s: %s-dot" nickname size)) | |
336 | (setq name nickname)) | |
337 | (cond ((string-match "^medium$" weight) | |
338 | (setq name (concat name " " "medium"))) | |
339 | ((string-match "^bold$\\|^demibold$" weight) | |
340 | (setq name (concat name " " weight)))) | |
341 | (cond ((string-match "^i$" slant) | |
342 | (setq name (concat name " " "italic"))) | |
343 | ((string-match "^o$" slant) | |
344 | (setq name (concat name " " "slant"))) | |
345 | ((string-match "^ri$" slant) | |
346 | (setq name (concat name " " "reverse italic"))) | |
347 | ((string-match "^ro$" slant) | |
348 | (setq name (concat name " " "reverse slant")))) | |
4ed46869 KH |
349 | name)) |
350 | fontset))) | |
351 | ||
35d4066a KH |
352 | (defvar uninstanciated-fontset-alist nil |
353 | "Alist of fontset names vs. information for instanciating them. | |
354 | Each element has the form (FONTSET STYLE BASE-FONTSET), where | |
355 | FONTSET is a name of fontset not yet instanciated. | |
356 | STYLE is a style of FONTSET, one of the followings: | |
357 | bold, demobold, italic, oblique, | |
358 | bold-italic, demibold-italic, bold-oblique, demibold-oblique. | |
359 | BASE-FONTSET is a name of fontset base from which FONSET is instanciated.") | |
360 | ||
b65976cb | 361 | (defun create-fontset-from-fontset-spec (fontset-spec &optional style noerror) |
4ed46869 KH |
362 | "Create a fontset from fontset specification string FONTSET-SPEC. |
363 | FONTSET-SPEC is a string of the format: | |
364 | FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ... | |
494ec9bc KH |
365 | Any number of SPACE, TAB, and NEWLINE can be put before and after commas. |
366 | If optional argument STYLE is specified, create a fontset of STYLE | |
367 | by modifying FONTSET-SPEC appropriately. STYLE can be one of `bold', | |
b65976cb | 368 | `italic', and `bold-italic'. |
883e21bd KH |
369 | If this function attempts to create already existing fontset, error is |
370 | signaled unless the optional 3rd argument NOERROR is non-nil." | |
494ec9bc KH |
371 | (if (not (string-match "^[^,]+" fontset-spec)) |
372 | (error "Invalid fontset spec: %s" fontset-spec)) | |
373 | (let ((idx (match-end 0)) | |
374 | (name (match-string 0 fontset-spec)) | |
375 | fontlist charset) | |
376 | ;; At first, extract pairs of charset and fontname from FONTSET-SPEC. | |
377 | (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx) | |
378 | (setq idx (match-end 0)) | |
379 | (setq charset (intern (match-string 1 fontset-spec))) | |
380 | (if (charsetp charset) | |
381 | (setq fontlist (cons (cons charset (match-string 2 fontset-spec)) | |
382 | fontlist)))) | |
383 | ||
494ec9bc KH |
384 | ;; If NAME conforms to XLFD, complement FONTLIST for charsets not |
385 | ;; specified in FONTSET-SPEC. | |
386 | (let ((xlfd-fields (x-decompose-font-name name))) | |
387 | (if xlfd-fields | |
388 | (setq fontlist | |
389 | (x-complement-fontset-spec xlfd-fields fontlist)))) | |
390 | ||
35d4066a KH |
391 | ;; If STYLE is specified, modify fontset name (NAME) and FONTLIST. |
392 | (if nil | |
393 | (let ((func (cdr (assq style '((bold . x-make-font-bold) | |
394 | (italic . x-make-font-italic) | |
395 | (bold-italic . x-make-font-bold-italic))))) | |
396 | (l fontlist) | |
397 | new-name) | |
398 | (if (and func | |
399 | (setq new-name (funcall func name))) | |
400 | (progn | |
401 | (setq name new-name) | |
402 | (while l | |
403 | (if (setq new-name (funcall func (cdr (car l)))) | |
404 | (setcdr (car l) new-name)) | |
405 | (setq l (cdr l)))))) | |
406 | (let ((funcs-alist | |
407 | '((bold x-make-font-bold) | |
408 | (demibold x-make-font-demibold) | |
409 | (italic x-make-font-italic) | |
410 | (oblique x-make-font-oblique) | |
411 | (bold-italic x-make-font-bold x-make-font-italic) | |
412 | (demibold-italic x-make-font-demibold x-make-font-italic) | |
413 | (bold-oblique x-make-font-bold x-make-font-oblique) | |
414 | (demibold-oblique x-make-font-demibold x-make-font-oblique))) | |
415 | new-name style funcs) | |
416 | (while funcs-alist | |
417 | (setq funcs (car funcs-alist)) | |
418 | (setq style (car funcs)) | |
419 | (setq funcs (cdr funcs)) | |
420 | (setq new-name name) | |
421 | (while funcs | |
422 | (setq new-name (funcall (car funcs) new-name)) | |
423 | (setq funcs (cdr funcs))) | |
424 | (setq uninstanciated-fontset-alist | |
425 | (cons (list new-name style name) uninstanciated-fontset-alist)) | |
426 | (setq funcs-alist (cdr funcs-alist))))) | |
427 | ||
b65976cb KH |
428 | (if (and noerror (query-fontset name)) |
429 | ;; Don't try to create an already existing fontset. | |
430 | nil | |
431 | ;; Create the fontset, and define the alias if appropriate. | |
432 | (new-fontset name fontlist) | |
433 | (if (and (not style) | |
434 | (not (assoc name fontset-alias-alist)) | |
435 | (string-match "fontset-.*$" name)) | |
436 | (let ((alias (match-string 0 name))) | |
437 | (or (rassoc alias fontset-alias-alist) | |
438 | (setq fontset-alias-alist | |
439 | (cons (cons name alias) fontset-alias-alist)))))))) | |
4ed46869 | 440 | |
35d4066a KH |
441 | (defun instanciate-fontset (fontset) |
442 | "Create a new fontset FONTSET if it is not yet instanciated. | |
443 | Return FONTSET if it is created successfully, else return nil." | |
444 | (let ((fontset-data (assoc fontset uninstanciated-fontset-alist))) | |
445 | (if (null fontset-data) | |
446 | nil | |
447 | (let ((style (nth 1 fontset-data)) | |
448 | (base-fontset (nth 2 fontset-data)) | |
449 | (funcs-alist | |
450 | '((bold x-make-font-bold) | |
451 | (demibold x-make-font-demibold) | |
452 | (italic x-make-font-italic) | |
453 | (oblique x-make-font-oblique) | |
454 | (bold-italic x-make-font-bold x-make-font-italic) | |
455 | (demibold-italic x-make-font-demibold x-make-font-italic) | |
456 | (bold-oblique x-make-font-bold x-make-font-oblique) | |
457 | (demibold-oblique x-make-font-demibold x-make-font-oblique))) | |
458 | ascii-font font font2 funcs) | |
459 | (setq uninstanciated-fontset-alist | |
460 | (delete fontset-data uninstanciated-fontset-alist)) | |
461 | (setq fontset-data (assoc base-fontset global-fontset-alist)) | |
462 | (setq ascii-font (cdr (assq 'ascii (cdr fontset-data)))) | |
463 | (setq funcs (cdr (assq style funcs-alist))) | |
464 | (if (= (length funcs) 1) | |
465 | (and (setq font (funcall (car funcs) ascii-font)) | |
466 | (setq font (x-resolve-font-name font 'default))) | |
467 | (and (setq font (funcall (car funcs) ascii-font)) | |
468 | (not (equal font ascii-font)) | |
469 | (setq font2 (funcall (nth 1 funcs) font)) | |
470 | (not (equal font2 font)) | |
471 | (setq font (x-resolve-font-name font2 'default)))) | |
472 | (when font | |
473 | (let ((new-fontset-data (copy-alist fontset-data))) | |
474 | (setq funcs (cdr (assq style funcs-alist))) | |
475 | (while funcs | |
476 | (setcar new-fontset-data | |
477 | (funcall (car funcs) (car new-fontset-data))) | |
478 | (let ((l (cdr new-fontset-data))) | |
479 | (while l | |
800d3b18 KH |
480 | (if (= (length funcs) 1) |
481 | (setq font (funcall (car funcs) (cdr (car l)))) | |
482 | (and (setq font (funcall (car funcs) (cdr (car l)))) | |
483 | (not (equal font (cdr (car l)))) | |
484 | (setq font2 (funcall (nth 1 funcs) font)) | |
485 | (not (equal font2 font)) | |
486 | (setq font font2))) | |
487 | (when font | |
488 | (setcdr (car l) font) | |
489 | (register-alternate-fontnames font)) | |
35d4066a KH |
490 | (setq l (cdr l)))) |
491 | (setq funcs (cdr funcs))) | |
492 | (new-fontset (car new-fontset-data) (cdr new-fontset-data)) | |
493 | (car new-fontset-data))))))) | |
4ed46869 | 494 | \f |
acfb10b8 | 495 | ;; Create standard fontset from 16 dots fonts which are the most widely |
80d4ea92 KH |
496 | ;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are |
497 | ;; specified here because FAMILY of those fonts are not "fixed" in | |
498 | ;; many cases. | |
acfb10b8 KH |
499 | (defvar standard-fontset-spec |
500 | "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard, | |
4ed46869 KH |
501 | chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*, |
502 | korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*, | |
503 | chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1, | |
504 | chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2, | |
505 | chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3, | |
506 | chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4, | |
507 | chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5, | |
508 | chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6, | |
509 | chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7" | |
acfb10b8 KH |
510 | "String of fontset spec of the standard fontset. |
511 | You have the biggest chance to display international characters | |
512 | with correct glyphs by using the standard fontset. | |
4ed46869 KH |
513 | See the documentation of `create-fontset-from-fontset-spec' for the format.") |
514 | ||
515 | ;; Create fontsets from X resources of the name `fontset-N (class | |
516 | ;; Fontset-N)' where N is integer 0, 1, ... | |
517 | ;; The values of the resources the string of the same format as | |
acfb10b8 | 518 | ;; `standard-fontset-spec'. |
4ed46869 KH |
519 | |
520 | (defun create-fontset-from-x-resource () | |
521 | (let ((idx 0) | |
522 | fontset-spec) | |
523 | (while (setq fontset-spec (x-get-resource (concat "fontset-" idx) | |
524 | (concat "Fontset-" idx))) | |
b65976cb | 525 | (create-fontset-from-fontset-spec fontset-spec nil 'noerror) |
4ed46869 KH |
526 | (setq idx (1+ idx))))) |
527 | ||
528 | (defsubst fontset-list () | |
529 | "Returns a list of all defined fontset names." | |
530 | (mapcar 'car global-fontset-alist)) | |
531 | ||
532 | ;; | |
533 | (provide 'fontset) | |
534 | ||
535 | ;;; fontset.el ends here |