17052
|
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
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
23
|
|
24 ;;; Code:
|
|
25
|
|
26 ;; Set default REGISTRY property of charset to find an appropriate
|
|
27 ;; font for each charset. This is used to generate a font name in a
|
|
28 ;; fontset. If the value contains a character `-', the string before
|
|
29 ;; that is embeded in `CHARSET_REGISTRY' field, and the string after
|
|
30 ;; that is embeded in `CHARSET_ENCODING' field. If the value does not
|
|
31 ;; contain `-', the whole string is embeded in `CHARSET_REGISTRY'
|
|
32 ;; field, and a wild card character `*' is embeded in
|
|
33 ;; `CHARSET_ENCODING' field.
|
|
34
|
|
35 (defvar x-charset-registries
|
|
36 '((ascii . "ISO8859-1")
|
|
37 (latin-iso8859-1 . "ISO8859-1")
|
|
38 (latin-iso8859-2 . "ISO8859-2")
|
|
39 (latin-iso8859-3 . "ISO8859-3")
|
|
40 (latin-iso8859-4 . "ISO8859-4")
|
|
41 (thai-tis620 . "TIS620")
|
|
42 (greek-iso8859-7 . "ISO8859-7")
|
|
43 (arabic-iso8859-6 . "ISO8859-6")
|
|
44 (hebrew-iso8859-8 . "ISO8859-8")
|
|
45 (katakana-jisx0201 . "JISX0201")
|
|
46 (latin-jisx0201 . "JISX0201")
|
|
47 (cyrillic-iso8859-5 . "ISO8859-5")
|
|
48 (latin-iso8859-9 . "ISO8859-9")
|
|
49 (japanese-jisx0208-1978 . "JISX0208.1978")
|
|
50 (chinese-gb2312 . "GB2312")
|
|
51 (japanese-jisx0208 . "JISX0208.1983")
|
|
52 (korean-ksc5601 . "KSC5601")
|
|
53 (japanese-jisx0212 . "JISX0212")
|
|
54 (chinese-cns11643-1 . "CNS11643.1992-1")
|
|
55 (chinese-cns11643-2 . "CNS11643.1992-2")
|
|
56 (chinese-cns11643-3 . "CNS11643.1992-3")
|
|
57 (chinese-cns11643-4 . "CNS11643.1992-4")
|
|
58 (chinese-cns11643-5 . "CNS11643.1992-5")
|
|
59 (chinese-cns11643-6 . "CNS11643.1992-6")
|
|
60 (chinese-cns11643-7 . "CNS11643.1992-7")
|
|
61 (chinese-big5-1 . "Big5")
|
|
62 (chinese-big5-2 . "Big5")
|
|
63 (chinese-sisheng . "sisheng_cwnn")
|
|
64 (vietnamese-viscii-lower . "VISCII1.1")
|
|
65 (vietnamese-viscii-upper . "VISCII1.1")
|
|
66 (arabic-digit . "MuleArabic-0")
|
|
67 (arabic-1-column . "MuleArabic-1")
|
|
68 (arabic-2-column . "MuleArabic-2")
|
|
69 (ipa . "MuleIPA")
|
|
70 (ethiopic . "Ethio")
|
|
71 (ascii-right-to-left . "ISO8859-1")
|
|
72 (indian-is13194 . "IS13194-Devanagari")
|
|
73 (indian-2-column . "MuleIndian-2")
|
|
74 (indian-1-column . "MuleIndian-1")
|
|
75 (lao . "lao.mule-1")))
|
|
76
|
|
77 (let ((l x-charset-registries))
|
|
78 (while l
|
|
79 (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
|
|
80 (setq l (cdr l))))
|
|
81
|
|
82 ;; Set arguments in `font-encoding-alist' (which see).
|
|
83 (defun set-font-encoding (pattern charset encoding)
|
|
84 (let ((slot (assoc pattern font-encoding-alist)))
|
|
85 (if slot
|
|
86 (let ((place (assq charset (cdr slot))))
|
|
87 (if place
|
|
88 (setcdr place encoding)
|
|
89 (setcdr slot (cons (cons charset encoding) (cdr slot)))))
|
|
90 (setq font-encoding-alist
|
|
91 (cons (list pattern (cons charset encoding)) font-encoding-alist)))
|
|
92 ))
|
|
93
|
|
94 (set-font-encoding "ISO8859-1" 'ascii 0)
|
|
95 (set-font-encoding "JISX0201" 'latin-jisx0201 0)
|
|
96
|
|
97 ;; Setting for suppressing XLoadQueryFont on big fonts.
|
|
98 (setq x-pixel-size-width-font-regexp
|
|
99 "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5")
|
|
100
|
|
101 ;;; XLFD (X Logical Font Description) format handler.
|
|
102
|
|
103 ;; Define XLFD's field index numbers. ; field name
|
|
104 (defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY
|
|
105 (defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME
|
|
106 (defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME
|
|
107 (defconst xlfd-regexp-slant-subnum 3) ; SLANT
|
|
108 (defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME
|
|
109 (defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME
|
|
110 (defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE
|
|
111 (defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE
|
|
112 (defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X
|
|
113 (defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y
|
|
114 (defconst xlfd-regexp-spacing-subnum 10) ; SPACING
|
|
115 (defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH
|
|
116 (defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY
|
|
117 (defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING
|
|
118
|
|
119 ;; Regular expression matching against a fontname which conforms to
|
|
120 ;; XLFD (X Logical Font Description). All fields in XLFD should be
|
|
121 ;; not be omitted (but can be a wild card) to be matched.
|
|
122 (defconst xlfd-tight-regexp
|
|
123 "^\
|
|
124 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
|
|
125 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\
|
|
126 -\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$")
|
|
127
|
|
128 ;; List of field numbers of XLFD whose values are numeric.
|
|
129 (defconst xlfd-regexp-numeric-subnums
|
|
130 (list xlfd-regexp-pixelsize-subnum ;6
|
|
131 xlfd-regexp-pointsize-subnum ;7
|
|
132 xlfd-regexp-resx-subnum ;8
|
|
133 xlfd-regexp-resy-subnum ;9
|
|
134 xlfd-regexp-avgwidth-subnum ;11
|
|
135 ))
|
|
136
|
|
137 (defun x-decompose-font-name (pattern)
|
|
138 "Decompose PATTERN into XLFD's fields and return vector of the fields.
|
|
139 The length of the vector is 14.
|
|
140
|
|
141 If PATTERN doesn't conform to XLFD, try to get a full XLFD name from
|
|
142 X server and use the information of the full name to decompose
|
|
143 PATTERN. If no full XLFD name is gotten, return nil."
|
|
144 (let (xlfd-fields fontname)
|
|
145 (if (string-match xlfd-tight-regexp pattern)
|
|
146 (let ((i 0))
|
|
147 (setq xlfd-fields (make-vector 14 nil))
|
|
148 (while (< i 14)
|
|
149 (aset xlfd-fields i (match-string (1+ i) pattern))
|
|
150 (setq i (1+ i)))
|
|
151 xlfd-fields)
|
|
152 (setq fontname (condition-case nil
|
|
153 (x-resolve-font-name pattern)
|
|
154 (error)))
|
|
155 (if (and fontname
|
|
156 (string-match xlfd-tight-regexp fontname))
|
|
157 (let ((len (length pattern))
|
|
158 (i 0)
|
|
159 l)
|
|
160 (setq xlfd-fields (make-vector 14 nil))
|
|
161 (while (< i 14)
|
|
162 (aset xlfd-fields i
|
|
163 (cons (match-beginning (1+ i))
|
|
164 (match-string (1+ i) fontname)))
|
|
165 (setq i (1+ i)))
|
|
166 (setq i 0)
|
|
167 (while (< i len)
|
|
168 (let ((ch (aref pattern i)))
|
|
169 (if (= ch ??)
|
|
170 (setq pattern (concat (substring pattern 0 i)
|
|
171 "\\(.\\)"
|
|
172 (substring pattern (1+ i)))
|
|
173 len (+ len 4)
|
|
174 i (+ i 4))
|
|
175 (if (= ch ?*)
|
|
176 (setq pattern (concat (substring pattern 0 i)
|
|
177 "\\(.*\\)"
|
|
178 (substring pattern (1+ i)))
|
|
179 len (+ len 5)
|
|
180 i (+ i 5))
|
|
181 (setq i (1+ i))))))
|
|
182 (string-match pattern fontname)
|
|
183 (setq l (cdr (cdr (match-data))))
|
|
184 (setq i 0)
|
|
185 (while (< i 14)
|
|
186 (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))
|
|
187 (progn
|
|
188 (aset xlfd-fields i (cdr (aref xlfd-fields i)))
|
|
189 (setq i (1+ i)))
|
|
190 (if (< (car (aref xlfd-fields i)) (car (cdr l)))
|
|
191 (progn
|
|
192 (aset xlfd-fields i nil)
|
|
193 (setq i (1+ i)))
|
|
194 (setq l (cdr (cdr l))))))
|
|
195 xlfd-fields)))))
|
|
196
|
|
197 (defsubst x-compose-font-name (xlfd-fields)
|
|
198 "Compose X's fontname from FIELDS.
|
|
199 FIELDS is a vector of XLFD fields.
|
|
200 If a field is nil, wild-card character `*' is embedded."
|
|
201 (concat "-" (mapconcat (lambda (x) (or x "*")) xlfd-fields "-")))
|
|
202
|
|
203 (defun x-complement-fontset-spec (xlfd-fields fontlist)
|
|
204 "Complement FONTLIST for all charsets based on XLFD-FIELDS and return it.
|
|
205 XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
|
|
206 FONTLIST is an alist of cons of charset and fontname.
|
|
207
|
|
208 Fontnames for charsets not listed in FONTLIST are generated from
|
|
209 XLFD-FIELDS and a property of x-charset-register of each charset
|
|
210 automatically."
|
|
211 (let ((charsets charset-list))
|
|
212 (while charsets
|
|
213 (let ((charset (car charsets)))
|
|
214 (if (null (assq charset fontlist))
|
|
215 (let ((registry (get-charset-property charset
|
|
216 'x-charset-registry)))
|
|
217 (if (string-match "-" registry)
|
|
218 ;; REGISTRY contains `CHARSET_ENCODING' field.
|
|
219 (progn
|
|
220 (aset xlfd-fields xlfd-regexp-registry-subnum
|
|
221 (substring registry 0 (match-beginning 0)))
|
|
222 (aset xlfd-fields xlfd-regexp-encoding-subnum
|
|
223 (substring registry (match-end 0))))
|
|
224 (aset xlfd-fields xlfd-regexp-registry-subnum
|
|
225 (concat registry "*"))
|
|
226 (aset xlfd-fields xlfd-regexp-encoding-subnum "*"))
|
|
227 (setq fontlist
|
|
228 (cons (cons charset (x-compose-font-name xlfd-fields))
|
|
229 fontlist)))))
|
|
230 (setq charsets (cdr charsets))))
|
|
231 fontlist)
|
|
232
|
|
233 ;; Return a list to be appended to `x-fixed-font-alist' when
|
|
234 ;; `mouse-set-font' is called.
|
|
235 (defun generate-fontset-menu ()
|
|
236 (let ((fontsets global-fontset-alist)
|
|
237 fontset-name
|
|
238 l)
|
|
239 (while fontsets
|
|
240 (setq fontset-name (car (car fontsets)) fontsets (cdr fontsets))
|
|
241 (if (string-match "fontset-\\([^-]+\\)" fontset-name)
|
|
242 ;; This fontset has a nickname. Just show it.
|
|
243 (let ((nickname (match-string 1 fontset-name)))
|
|
244 (setq l (cons (list (concat ".." nickname) fontset-name) l)))
|
|
245 (setq l (cons (list fontset-name fontset-name) l))))
|
|
246 (cons "Fontset" l)))
|
|
247
|
|
248 (defun fontset-plain-name (fontset)
|
|
249 "Return a plain and descriptive name of FONTSET."
|
|
250 (let ((xlfd-fields (x-decompose-font-name fontset)))
|
|
251 (if xlfd-fields
|
|
252 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum))
|
|
253 (slant (aref xlfd-fields xlfd-regexp-slant-subnum))
|
|
254 (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum))
|
|
255 (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum))
|
|
256 name)
|
|
257 (if (integerp size)
|
|
258 (setq name (format "%d " size))
|
|
259 (setq name ""))
|
|
260 (if (string-match "bold\\|demibold" weight)
|
|
261 (setq name (concat name weight " ")))
|
|
262 (cond ((string= slant "i")
|
|
263 (setq name (concat name "italic ")))
|
|
264 ((string= slant "o")
|
|
265 (setq name (concat name "slant ")))
|
|
266 ((string= slant "ri")
|
|
267 (setq name (concat name "reverse italic ")))
|
|
268 ((string= slant "ro")
|
|
269 (setq name (concat name "reverse slant "))))
|
|
270 (if (= (length name) 0)
|
|
271 ;; No descriptive fields found.
|
|
272 fontset
|
|
273 name))
|
|
274 fontset)))
|
|
275
|
|
276 (defun create-fontset-from-fontset-spec (fontset-spec)
|
|
277 "Create a fontset from fontset specification string FONTSET-SPEC.
|
|
278 FONTSET-SPEC is a string of the format:
|
|
279 FONTSET-NAME,CHARSET-NAME0:FONT-NAME0,CHARSET-NAME1:FONT-NAME1, ...
|
|
280 Any number of SPACE, TAB, and NEWLINE can be put before and after commas."
|
|
281 (if (string-match "[^,]+" fontset-spec)
|
|
282 (let* ((idx2 (match-end 0))
|
|
283 (name (match-string 0 fontset-spec))
|
|
284 fontlist charset xlfd-fields)
|
|
285 (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)"
|
|
286 fontset-spec idx2)
|
|
287 (setq idx2 (match-end 0))
|
|
288 (setq charset (intern (match-string 1 fontset-spec)))
|
|
289 (if (charsetp charset)
|
|
290 (setq fontlist (cons (cons charset (match-string 2 fontset-spec))
|
|
291 fontlist))))
|
|
292 (if (setq xlfd-fields (x-decompose-font-name name))
|
|
293 ;; If NAME conforms to XLFD, complement FONTLIST for
|
|
294 ;; charsets not specified in FONTSET-SPEC.
|
|
295 (setq fontlist
|
|
296 (x-complement-fontset-spec xlfd-fields fontlist)))
|
|
297 (new-fontset name fontlist))))
|
|
298
|
|
299
|
|
300 ;; Create default fontset from 16 dots fonts which are the most widely
|
|
301 ;; installed fonts.
|
|
302 (defvar default-fontset-spec
|
|
303 "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-default,
|
|
304 chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
|
|
305 korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
|
|
306 chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
|
|
307 chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
|
|
308 chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
|
|
309 chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
|
|
310 chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
|
|
311 chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
|
|
312 chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
|
|
313 "String of fontset spec of a default fontset.
|
|
314 See the documentation of `create-fontset-from-fontset-spec' for the format.")
|
|
315
|
|
316 ;; Create fontsets from X resources of the name `fontset-N (class
|
|
317 ;; Fontset-N)' where N is integer 0, 1, ...
|
|
318 ;; The values of the resources the string of the same format as
|
|
319 ;; `default-fontset-spec'.
|
|
320
|
|
321 (defun create-fontset-from-x-resource ()
|
|
322 (let ((idx 0)
|
|
323 fontset-spec)
|
|
324 (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
|
|
325 (concat "Fontset-" idx)))
|
|
326 (create-fontset-from-fontset-spec fontset-spec)
|
|
327 (setq idx (1+ idx)))))
|
|
328
|
|
329 (defsubst fontset-list ()
|
|
330 "Returns a list of all defined fontset names."
|
|
331 (mapcar 'car global-fontset-alist))
|
|
332
|
|
333 ;;
|
|
334 (provide 'fontset)
|
|
335
|
|
336 ;;; fontset.el ends here
|