Commit | Line | Data |
---|---|---|
4ed46869 KH |
1 | ;;; fontset.el --- Commands for handling fontset. |
2 | ||
3 | ;; Copyright (C) 1995 Free Software Foundation, Inc. | |
4 | ;; Copyright (C) 1995 Electrotechnical Laboratory, JAPAN. | |
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 | ||
27 | ;; Set default REGISTRY property of charset to find an appropriate | |
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") | |
b55b5129 | 76 | (lao . "lao.mule-1") |
4b1a66da RS |
77 | ;; (tibetan . "Mule.Tibetan-0") |
78 | ;; (tibetan-1-column . "Mule.Tibetan-1") | |
b55b5129 | 79 | )) |
4ed46869 KH |
80 | |
81 | (let ((l x-charset-registries)) | |
82 | (while l | |
83 | (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l))) | |
84 | (setq l (cdr l)))) | |
85 | ||
86 | ;; Set arguments in `font-encoding-alist' (which see). | |
87 | (defun set-font-encoding (pattern charset encoding) | |
88 | (let ((slot (assoc pattern font-encoding-alist))) | |
89 | (if slot | |
90 | (let ((place (assq charset (cdr slot)))) | |
91 | (if place | |
92 | (setcdr place encoding) | |
93 | (setcdr slot (cons (cons charset encoding) (cdr slot))))) | |
94 | (setq font-encoding-alist | |
95 | (cons (list pattern (cons charset encoding)) font-encoding-alist))) | |
96 | )) | |
97 | ||
98 | (set-font-encoding "ISO8859-1" 'ascii 0) | |
99 | (set-font-encoding "JISX0201" 'latin-jisx0201 0) | |
100 | ||
101 | ;; Setting for suppressing XLoadQueryFont on big fonts. | |
102 | (setq x-pixel-size-width-font-regexp | |
103 | "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5") | |
104 | ||
105 | ;;; XLFD (X Logical Font Description) format handler. | |
106 | ||
107 | ;; Define XLFD's field index numbers. ; field name | |
108 | (defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY | |
109 | (defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME | |
110 | (defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME | |
111 | (defconst xlfd-regexp-slant-subnum 3) ; SLANT | |
112 | (defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME | |
113 | (defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME | |
114 | (defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE | |
115 | (defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE | |
116 | (defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X | |
117 | (defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y | |
118 | (defconst xlfd-regexp-spacing-subnum 10) ; SPACING | |
119 | (defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH | |
120 | (defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY | |
121 | (defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING | |
122 | ||
123 | ;; Regular expression matching against a fontname which conforms to | |
124 | ;; XLFD (X Logical Font Description). All fields in XLFD should be | |
125 | ;; not be omitted (but can be a wild card) to be matched. | |
126 | (defconst xlfd-tight-regexp | |
127 | "^\ | |
128 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ | |
129 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ | |
130 | -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$") | |
131 | ||
132 | ;; List of field numbers of XLFD whose values are numeric. | |
133 | (defconst xlfd-regexp-numeric-subnums | |
134 | (list xlfd-regexp-pixelsize-subnum ;6 | |
135 | xlfd-regexp-pointsize-subnum ;7 | |
136 | xlfd-regexp-resx-subnum ;8 | |
137 | xlfd-regexp-resy-subnum ;9 | |
138 | xlfd-regexp-avgwidth-subnum ;11 | |
139 | )) | |
140 | ||
141 | (defun x-decompose-font-name (pattern) | |
142 | "Decompose PATTERN into XLFD's fields and return vector of the fields. | |
143 | The length of the vector is 14. | |
144 | ||
145 | If PATTERN doesn't conform to XLFD, try to get a full XLFD name from | |
146 | X server and use the information of the full name to decompose | |
147 | PATTERN. If no full XLFD name is gotten, return nil." | |
148 | (let (xlfd-fields fontname) | |
149 | (if (string-match xlfd-tight-regexp pattern) | |
150 | (let ((i 0)) | |
151 | (setq xlfd-fields (make-vector 14 nil)) | |
152 | (while (< i 14) | |
153 | (aset xlfd-fields i (match-string (1+ i) pattern)) | |
154 | (setq i (1+ i))) | |
155 | xlfd-fields) | |
156 | (setq fontname (condition-case nil | |
157 | (x-resolve-font-name pattern) | |
158 | (error))) | |
159 | (if (and fontname | |
160 | (string-match xlfd-tight-regexp fontname)) | |
161 | (let ((len (length pattern)) | |
162 | (i 0) | |
163 | l) | |
164 | (setq xlfd-fields (make-vector 14 nil)) | |
165 | (while (< i 14) | |
166 | (aset xlfd-fields i | |
167 | (cons (match-beginning (1+ i)) | |
168 | (match-string (1+ i) fontname))) | |
169 | (setq i (1+ i))) | |
170 | (setq i 0) | |
171 | (while (< i len) | |
172 | (let ((ch (aref pattern i))) | |
173 | (if (= ch ??) | |
174 | (setq pattern (concat (substring pattern 0 i) | |
175 | "\\(.\\)" | |
176 | (substring pattern (1+ i))) | |
177 | len (+ len 4) | |
178 | i (+ i 4)) | |
179 | (if (= ch ?*) | |
180 | (setq pattern (concat (substring pattern 0 i) | |
181 | "\\(.*\\)" | |
182 | (substring pattern (1+ i))) | |
183 | len (+ len 5) | |
184 | i (+ i 5)) | |
185 | (setq i (1+ i)))))) | |
186 | (string-match pattern fontname) | |
187 | (setq l (cdr (cdr (match-data)))) | |
188 | (setq i 0) | |
189 | (while (< i 14) | |
190 | (if (or (null l) (< (car (aref xlfd-fields i)) (car l))) | |
191 | (progn | |
192 | (aset xlfd-fields i (cdr (aref xlfd-fields i))) | |
193 | (setq i (1+ i))) | |
194 | (if (< (car (aref xlfd-fields i)) (car (cdr l))) | |
195 | (progn | |
196 | (aset xlfd-fields i nil) | |
197 | (setq i (1+ i))) | |
198 | (setq l (cdr (cdr l)))))) | |
199 | xlfd-fields))))) | |
200 | ||
441038a6 KH |
201 | ;; Replace consecutive wild-cards (`*') in NAME to one. |
202 | ;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1" | |
203 | (defsubst x-reduce-font-name (name) | |
204 | (while (string-match "-\\*-\\(\\*-\\)+" name) | |
205 | (setq name (replace-match "-*-" t t name))) | |
206 | name) | |
207 | ||
208 | (defun x-compose-font-name (xlfd-fields &optional reduce) | |
4ed46869 KH |
209 | "Compose X's fontname from FIELDS. |
210 | FIELDS is a vector of XLFD fields. | |
441038a6 KH |
211 | If a field is nil, wild-card letter `*' is embedded. |
212 | Optional argument REDUCE non-nil means consecutive wild-cards are | |
213 | reduced to be one." | |
214 | (let ((name | |
215 | (concat "-" (mapconcat (lambda (x) (or x "*")) xlfd-fields "-")))) | |
216 | (if reduce | |
217 | (x-reduce-font-name name) | |
218 | name))) | |
4ed46869 KH |
219 | |
220 | (defun x-complement-fontset-spec (xlfd-fields fontlist) | |
221 | "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it. | |
222 | XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields. | |
223 | FONTLIST is an alist of cons of charset and fontname. | |
224 | ||
225 | Fontnames for charsets not listed in FONTLIST are generated from | |
226 | XLFD-FIELDS and a property of x-charset-register of each charset | |
227 | automatically." | |
6b1e91e3 KH |
228 | (let ((charsets charset-list) |
229 | (loose-xlfd-fields (copy-sequence xlfd-fields))) | |
230 | (aset loose-xlfd-fields xlfd-regexp-pixelsize-subnum nil) | |
231 | (aset loose-xlfd-fields xlfd-regexp-pointsize-subnum nil) | |
232 | (aset loose-xlfd-fields xlfd-regexp-resx-subnum nil) | |
233 | (aset loose-xlfd-fields xlfd-regexp-resy-subnum nil) | |
234 | (aset loose-xlfd-fields xlfd-regexp-spacing-subnum nil) | |
235 | (aset loose-xlfd-fields xlfd-regexp-avgwidth-subnum nil) | |
4ed46869 KH |
236 | (while charsets |
237 | (let ((charset (car charsets))) | |
238 | (if (null (assq charset fontlist)) | |
239 | (let ((registry (get-charset-property charset | |
6b1e91e3 KH |
240 | 'x-charset-registry)) |
241 | registry-val encoding-val fontname loose-fontname) | |
4ed46869 KH |
242 | (if (string-match "-" registry) |
243 | ;; REGISTRY contains `CHARSET_ENCODING' field. | |
6b1e91e3 KH |
244 | (setq registry-val (substring registry 0 (match-beginning 0)) |
245 | encoding-val (substring registry (match-end 0))) | |
246 | (setq registry-val (concat registry "*") | |
247 | encoding-val "*")) | |
248 | (aset xlfd-fields xlfd-regexp-registry-subnum registry-val) | |
249 | (aset xlfd-fields xlfd-regexp-encoding-subnum encoding-val) | |
250 | (aset loose-xlfd-fields xlfd-regexp-registry-subnum registry-val) | |
251 | (aset loose-xlfd-fields xlfd-regexp-encoding-subnum encoding-val) | |
252 | (setq fontname (x-compose-font-name xlfd-fields t)) | |
253 | (setq fontlist (cons (cons charset fontname) fontlist)) | |
254 | (or (assoc fontname alternative-fontname-alist) | |
255 | (setq alternative-fontname-alist | |
256 | (cons (list | |
257 | fontname | |
258 | (x-compose-font-name loose-xlfd-fields t) | |
259 | (concat "*-" registry-val "-" encoding-val)) | |
260 | alternative-fontname-alist))) | |
261 | ))) | |
4ed46869 KH |
262 | (setq charsets (cdr charsets)))) |
263 | fontlist) | |
264 | ||
265 | ;; Return a list to be appended to `x-fixed-font-alist' when | |
266 | ;; `mouse-set-font' is called. | |
267 | (defun generate-fontset-menu () | |
268 | (let ((fontsets global-fontset-alist) | |
269 | fontset-name | |
270 | l) | |
271 | (while fontsets | |
272 | (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets)) | |
273 | (if (string-match "fontset-\\([^-]+\\)" fontset-name) | |
274 | ;; This fontset has a nickname. Just show it. | |
275 | (let ((nickname (match-string 1 fontset-name))) | |
276 | (setq l (cons (list (concat ".." nickname) fontset-name) l))) | |
277 | (setq l (cons (list fontset-name fontset-name) l)))) | |
278 | (cons "Fontset" l))) | |
279 | ||
280 | (defun fontset-plain-name (fontset) | |
281 | "Return a plain and descriptive name of FONTSET." | |
282 | (let ((xlfd-fields (x-decompose-font-name fontset))) | |
283 | (if xlfd-fields | |
284 | (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum)) | |
285 | (slant (aref xlfd-fields xlfd-regexp-slant-subnum)) | |
286 | (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum)) | |
287 | (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum)) | |
288 | name) | |
441038a6 KH |
289 | (if (> (string-to-int size) 0) |
290 | (setq name (format "%s " size)) | |
4ed46869 KH |
291 | (setq name "")) |
292 | (if (string-match "bold\\|demibold" weight) | |
293 | (setq name (concat name weight " "))) | |
294 | (cond ((string= slant "i") | |
295 | (setq name (concat name "italic "))) | |
296 | ((string= slant "o") | |
297 | (setq name (concat name "slant "))) | |
298 | ((string= slant "ri") | |
299 | (setq name (concat name "reverse italic "))) | |
300 | ((string= slant "ro") | |
301 | (setq name (concat name "reverse slant ")))) | |
302 | (if (= (length name) 0) | |
303 | ;; No descriptive fields found. | |
304 | fontset | |
305 | name)) | |
306 | fontset))) | |
307 | ||
308 | (defun create-fontset-from-fontset-spec (fontset-spec) | |
309 | "Create a fontset from fontset specification string FONTSET-SPEC. | |
310 | FONTSET-SPEC is a string of the format: | |
311 | FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ... | |
312 | Any number of SPACE, TAB, and NEWLINE can be put before and after commas." | |
313 | (if (string-match "[^,]+" fontset-spec) | |
314 | (let* ((idx2 (match-end 0)) | |
315 | (name (match-string 0 fontset-spec)) | |
316 | fontlist charset xlfd-fields) | |
317 | (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" | |
318 | fontset-spec idx2) | |
319 | (setq idx2 (match-end 0)) | |
320 | (setq charset (intern (match-string 1 fontset-spec))) | |
321 | (if (charsetp charset) | |
322 | (setq fontlist (cons (cons charset (match-string 2 fontset-spec)) | |
323 | fontlist)))) | |
324 | (if (setq xlfd-fields (x-decompose-font-name name)) | |
325 | ;; If NAME conforms to XLFD, complement FONTLIST for | |
326 | ;; charsets not specified in FONTSET-SPEC. | |
327 | (setq fontlist | |
328 | (x-complement-fontset-spec xlfd-fields fontlist))) | |
329 | (new-fontset name fontlist)))) | |
330 | ||
331 | \f | |
332 | ;; Create default fontset from 16 dots fonts which are the most widely | |
333 | ;; installed fonts. | |
334 | (defvar default-fontset-spec | |
335 | "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-default, | |
336 | chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*, | |
337 | korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*, | |
338 | chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1, | |
339 | chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2, | |
340 | chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3, | |
341 | chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4, | |
342 | chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5, | |
343 | chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6, | |
344 | chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7" | |
345 | "String of fontset spec of a default fontset. | |
346 | See the documentation of `create-fontset-from-fontset-spec' for the format.") | |
347 | ||
348 | ;; Create fontsets from X resources of the name `fontset-N (class | |
349 | ;; Fontset-N)' where N is integer 0, 1, ... | |
350 | ;; The values of the resources the string of the same format as | |
351 | ;; `default-fontset-spec'. | |
352 | ||
353 | (defun create-fontset-from-x-resource () | |
354 | (let ((idx 0) | |
355 | fontset-spec) | |
356 | (while (setq fontset-spec (x-get-resource (concat "fontset-" idx) | |
357 | (concat "Fontset-" idx))) | |
358 | (create-fontset-from-fontset-spec fontset-spec) | |
359 | (setq idx (1+ idx))))) | |
360 | ||
361 | (defsubst fontset-list () | |
362 | "Returns a list of all defined fontset names." | |
363 | (mapcar 'car global-fontset-alist)) | |
364 | ||
365 | ;; | |
366 | (provide 'fontset) | |
367 | ||
368 | ;;; fontset.el ends here |