1;;; fontset.el --- commands for handling fontset 2 3;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 6;; 2005, 2006, 2007 7;; National Institute of Advanced Industrial Science and Technology (AIST) 8;; Registration Number H14PRO021 9 10;; Keywords: mule, multilingual, fontset 11 12;; This file is part of GNU Emacs. 13 14;; GNU Emacs is free software; you can redistribute it and/or modify 15;; it 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;; GNU Emacs is distributed in the hope that it will be useful, 20;; but WITHOUT ANY WARRANTY; without even the implied warranty of 21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 22;; GNU General Public License for more details. 23 24;; You should have received a copy of the GNU General Public License 25;; along with GNU Emacs; see the file COPYING. If not, write to the 26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 27;; Boston, MA 02110-1301, USA. 28 29;;; Commentary: 30 31;;; Code: 32 33;; Set standard fontname specification of characters in the default 34;; fontset to find an appropriate font for each charset. This is used 35;; to generate a font name for a fontset if the fontset doesn't 36;; specify a font name for a specific character. The specification 37;; has the form (FAMILY . REGISTRY). FAMILY may be nil, in which 38;; case, the family name of default face is used. If REGISTRY 39;; contains a character `-', the string before that is embedded in 40;; `CHARSET_REGISTRY' field, and the string after that is embedded in 41;; `CHARSET_ENCODING' field. If it does not contain `-', the whole 42;; string is embedded in `CHARSET_REGISTRY' field, and a wild card 43;; character `*' is embedded in `CHARSET_ENCODING' field. The 44;; REGISTRY for ASCII characters are predefined as "ISO8859-1". 45 46(defun setup-default-fontset () 47 "Setup the default fontset." 48 (dolist (elt 49 `((latin-iso8859-1 . (nil . "ISO8859-1")) 50 (latin-iso8859-2 . (nil . "ISO8859-2")) 51 (latin-iso8859-3 . (nil . "ISO8859-3")) 52 (latin-iso8859-4 . (nil . "ISO8859-4")) 53 ;; Setting "*" family is for a workaround of the problem 54 ;; that a font of wrong size is preferred if the font 55 ;; family matches with a requested one. 56 (thai-tis620 . ("*" . "TIS620")) 57 (greek-iso8859-7 . (nil . "ISO8859-7")) 58 (arabic-iso8859-6 . (nil . "ISO8859-6")) 59 (hebrew-iso8859-8 . (nil . "ISO8859-8")) 60 (katakana-jisx0201 . (nil . "JISX0201")) 61 (latin-jisx0201 . (nil . "JISX0201")) 62 (cyrillic-iso8859-5 . (nil . "ISO8859-5")) 63 (latin-iso8859-9 . (nil . "ISO8859-9")) 64 (japanese-jisx0208-1978 . (nil . "JISX0208.1978")) 65 (chinese-gb2312 . (nil . "GB2312.1980")) 66 (japanese-jisx0208 . (nil . "JISX0208.1990")) 67 (korean-ksc5601 . (nil . "KSC5601.1989")) 68 (japanese-jisx0212 . (nil . "JISX0212")) 69 (chinese-cns11643-1 . (nil . "CNS11643.1992-1")) 70 (chinese-cns11643-2 . (nil . "CNS11643.1992-2")) 71 (chinese-cns11643-3 . (nil . "CNS11643.1992-3")) 72 (chinese-cns11643-4 . (nil . "CNS11643.1992-4")) 73 (chinese-cns11643-5 . (nil . "CNS11643.1992-5")) 74 (chinese-cns11643-6 . (nil . "CNS11643.1992-6")) 75 (chinese-cns11643-7 . (nil . "CNS11643.1992-7")) 76 (chinese-big5-1 . (nil . "Big5")) 77 (chinese-big5-2 . (nil . "Big5")) 78 (chinese-sisheng . (nil . "sisheng_cwnn")) 79 (vietnamese-viscii-lower . (nil . "VISCII1.1")) 80 (vietnamese-viscii-upper . (nil . "VISCII1.1")) 81 (arabic-digit . (nil . "MuleArabic-0")) 82 (arabic-1-column . (nil . "MuleArabic-1")) 83 (arabic-2-column . (nil . "MuleArabic-2")) 84 (ipa . (nil . "MuleIPA")) 85 (ethiopic . (nil . "Ethiopic-Unicode")) 86 (ascii-right-to-left . (nil . "ISO8859-1")) 87 (indian-is13194 . (nil . "IS13194-Devanagari")) 88 (indian-2-column . (nil . "MuleIndian-2")) 89 (lao . (nil . "MuleLao-1")) 90 (tibetan . ("proportional" . "MuleTibetan-2")) 91 (tibetan-1-column . (nil . "MuleTibetan-1")) 92 (latin-iso8859-14 . (nil . "ISO8859-14")) 93 (latin-iso8859-15 . (nil . "ISO8859-15")) 94 (mule-unicode-0100-24ff . (nil . "ISO10646-1")) 95 (mule-unicode-2500-33ff . (nil . "ISO10646-1")) 96 (mule-unicode-e000-ffff . (nil . "ISO10646-1")) 97 (japanese-jisx0213-1 . (nil . "JISX0213.2000-1")) 98 (japanese-jisx0213-2 . (nil . "JISX0213.2000-2")) 99 ;; unicode 100 ((,(decode-char 'ucs #x0900) . ,(decode-char 'ucs #x097F)) 101 . (nil . "ISO10646.indian-1")) 102 ;; Indian CDAC 103 (,(indian-font-char-range 'cdac:dv-ttsurekh) 104 . (nil . "Devanagari-CDAC")) 105 (,(indian-font-char-range 'cdac:sd-ttsurekh) 106 . (nil . "Sanskrit-CDAC")) 107 (,(indian-font-char-range 'cdac:bn-ttdurga) 108 . (nil . "Bengali-CDAC")) 109 (,(indian-font-char-range 'cdac:as-ttdurga) 110 . (nil . "Assamese-CDAC")) 111 (,(indian-font-char-range 'cdac:pn-ttamar) 112 . (nil . "Punjabi-CDAC")) 113 (,(indian-font-char-range 'cdac:gj-ttavantika) 114 . (nil . "Gujarati-CDAC")) 115 (,(indian-font-char-range 'cdac:or-ttsarala) 116 . (nil . "Oriya-CDAC")) 117 (,(indian-font-char-range 'cdac:tm-ttvalluvar) 118 . (nil . "Tamil-CDAC")) 119 (,(indian-font-char-range 'cdac:tl-tthemalatha) 120 . (nil . "Telugu-CDAC")) 121 (,(indian-font-char-range 'cdac:kn-ttuma) 122 . (nil . "Kannada-CDAC")) 123 (,(indian-font-char-range 'cdac:ml-ttkarthika) 124 . (nil . "Malayalam-CDAC")) 125 ;; Indian AKRUTI 126 (,(indian-font-char-range 'akruti:dev) 127 . (nil . "Devanagari-Akruti")) 128 (,(indian-font-char-range 'akruti:bng) 129 . (nil . "Bengali-Akruti")) 130 (,(indian-font-char-range 'akruti:pnj) 131 . (nil . "Punjabi-Akruti")) 132 (,(indian-font-char-range 'akruti:guj) 133 . (nil . "Gujarati-Akruti")) 134 (,(indian-font-char-range 'akruti:ori) 135 . (nil . "Oriya-Akruti")) 136 (,(indian-font-char-range 'akruti:tml) 137 . (nil . "Tamil-Akruti")) 138 (,(indian-font-char-range 'akruti:tlg) 139 . (nil . "Telugu-Akruti")) 140 (,(indian-font-char-range 'akruti:knd) 141 . (nil . "Kannada-Akruti")) 142 (,(indian-font-char-range 'akruti:mal) 143 . (nil . "Malayalam-Akruti")) 144 )) 145 (set-fontset-font "fontset-default" (car elt) (cdr elt)))) 146 147;; Set arguments in `font-encoding-alist' (which see). 148(defun set-font-encoding (pattern charset encoding) 149 (let ((slot (assoc pattern font-encoding-alist))) 150 (if slot 151 (let ((place (assq charset (cdr slot)))) 152 (if place 153 (setcdr place encoding) 154 (setcdr slot (cons (cons charset encoding) (cdr slot))))) 155 (setq font-encoding-alist 156 (cons (list pattern (cons charset encoding)) font-encoding-alist))) 157 )) 158 159;; Allow display of arbitrary characters with an iso-10646-encoded 160;; (`Unicode') font. 161(define-translation-table 'ucs-mule-to-mule-unicode 162 ucs-mule-to-mule-unicode) 163(define-translation-hash-table 'ucs-mule-cjk-to-unicode 164 ucs-mule-cjk-to-unicode) 165 166(define-ccl-program ccl-encode-unicode-font 167 `(0 168 ;; r0: charset-id 169 ;; r1: 1st position code 170 ;; r2: 2nd position code (if r0 is 2D charset) 171 ((if (r0 == ,(charset-id 'ascii)) 172 ((r2 = r1) 173 (r1 = 0)) 174 ;; At first, try to get a Unicode code point directly. 175 ((if (r2 >= 0) 176 ;; This is a 2D charset. 177 (r1 = ((r1 << 7) | r2))) 178 (lookup-character utf-subst-table-for-encode r0 r1) 179 (if r7 180 ;; We got it! 181 ((r1 = (r0 >> 8)) 182 (r2 = (r0 & #xFF))) 183 ;; Look for a translation for non-ASCII chars. 184 ((translate-character ucs-mule-to-mule-unicode r0 r1) 185 (if (r0 == ,(charset-id 'ascii)) 186 ((r2 = r1) 187 (r1 = 0)) 188 ((if (r0 == ,(charset-id 'latin-iso8859-1)) 189 ((r2 = (r1 + 128)) 190 (r1 = 0)) 191 ((r2 = (r1 & #x7F)) 192 (r1 >>= 7) 193 (if (r0 == ,(charset-id 'mule-unicode-0100-24ff)) 194 ((r1 *= 96) 195 (r1 += r2) 196 (r1 += ,(- #x100 (* 32 96) 32)) 197 (r1 >8= 0) 198 (r2 = r7)) 199 (if (r0 == ,(charset-id 'mule-unicode-2500-33ff)) 200 ((r1 *= 96) 201 (r1 += r2) 202 (r1 += ,(- #x2500 (* 32 96) 32)) 203 (r1 >8= 0) 204 (r2 = r7)) 205 (if (r0 == ,(charset-id 'mule-unicode-e000-ffff)) 206 ((r1 *= 96) 207 (r1 += r2) 208 (r1 += ,(- #xe000 (* 32 96) 32)) 209 (r1 >8= 0) 210 (r2 = r7)) 211 ;; No way, use the glyph for U+FFFD. 212 ((r1 = #xFF) 213 (r2 = #xFD))))))))))))))) 214 "Encode characters for display with iso10646 font. 215Translate through the translation-hash-table named 216`ucs-mule-cjk-to-unicode' and the translation-table named 217`ucs-mule-to-mule-unicode' initially.") 218 219;; Use the above CCL encoder for Unicode fonts. Please note that the 220;; regexp is not simply "ISO10646-1" because there exists, for 221;; instance, the following Devanagari Unicode fonts: 222;; -misc-fixed-medium-r-normal--24-240-72-72-c-120-iso10646.indian-1 223;; -sibal-devanagari-medium-r-normal--24-240-75-75-P--iso10646-dev 224(setq font-ccl-encoder-alist 225 (cons '("ISO10646.*-*" . ccl-encode-unicode-font) 226 font-ccl-encoder-alist)) 227 228;; Setting for suppressing XLoadQueryFont on big fonts. 229(setq x-pixel-size-width-font-regexp 230 "gb2312\\|jisx0208\\|ksc5601\\|cns11643\\|big5") 231 232;; These fonts require vertical centering. 233(setq vertical-centering-font-regexp 234 "gb2312\\|jisx0208\\|jisx0212\\|ksc5601\\|cns11643\\|big5") 235 236;; CDAC fonts are actually smaller than their design sizes. 237(setq face-font-rescale-alist 238 '(("-cdac$" . 1.3))) 239 240(defvar x-font-name-charset-alist 241 '(("iso8859-1" ascii latin-iso8859-1) 242 ("iso8859-2" ascii latin-iso8859-2) 243 ("iso8859-3" ascii latin-iso8859-3) 244 ("iso8859-4" ascii latin-iso8859-4) 245 ("iso8859-5" ascii cyrillic-iso8859-5) 246 ("iso8859-6" ascii arabic-iso8859-6) 247 ("iso8859-7" ascii greek-iso8859-7) 248 ("iso8859-8" ascii hebrew-iso8859-8) 249 ("iso8859-14" ascii latin-iso8859-14) 250 ("iso8859-15" ascii latin-iso8859-15) 251 ("tis620" ascii thai-tis620) 252 ("koi8" ascii cyrillic-iso8859-5) 253 ("viscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower) 254 ("vscii" ascii vietnamese-viscii-upper vietnamese-viscii-lower) 255 ("mulelao-1" ascii lao) 256 ("iso10646-1" ascii latin-iso8859-1 mule-unicode-0100-24ff 257 mule-unicode-2500-33ff mule-unicode-e000-ffff)) 258 "Alist of font names vs list of charsets the font can display. 259 260When a font name which matches some element of this alist is given as 261`-fn' command line argument or is specified by X resource, a fontset 262which uses the specified font for the corresponding charsets are 263created and used for the initial frame.") 264 265;;; XLFD (X Logical Font Description) format handler. 266 267;; Define XLFD's field index numbers. ; field name 268(defconst xlfd-regexp-foundry-subnum 0) ; FOUNDRY 269(defconst xlfd-regexp-family-subnum 1) ; FAMILY_NAME 270(defconst xlfd-regexp-weight-subnum 2) ; WEIGHT_NAME 271(defconst xlfd-regexp-slant-subnum 3) ; SLANT 272(defconst xlfd-regexp-swidth-subnum 4) ; SETWIDTH_NAME 273(defconst xlfd-regexp-adstyle-subnum 5) ; ADD_STYLE_NAME 274(defconst xlfd-regexp-pixelsize-subnum 6) ; PIXEL_SIZE 275(defconst xlfd-regexp-pointsize-subnum 7) ; POINT_SIZE 276(defconst xlfd-regexp-resx-subnum 8) ; RESOLUTION_X 277(defconst xlfd-regexp-resy-subnum 9) ; RESOLUTION_Y 278(defconst xlfd-regexp-spacing-subnum 10) ; SPACING 279(defconst xlfd-regexp-avgwidth-subnum 11) ; AVERAGE_WIDTH 280(defconst xlfd-regexp-registry-subnum 12) ; CHARSET_REGISTRY 281(defconst xlfd-regexp-encoding-subnum 13) ; CHARSET_ENCODING 282 283;; Regular expression matching against a fontname which conforms to 284;; XLFD (X Logical Font Description). All fields in XLFD should be 285;; not be omitted (but can be a wild card) to be matched. 286(defconst xlfd-tight-regexp 287 "^\ 288-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ 289-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)\ 290-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)-\\([^-]*\\)$") 291 292;; List of field numbers of XLFD whose values are numeric. 293(defconst xlfd-regexp-numeric-subnums 294 (list xlfd-regexp-pixelsize-subnum ;6 295 xlfd-regexp-pointsize-subnum ;7 296 xlfd-regexp-resx-subnum ;8 297 xlfd-regexp-resy-subnum ;9 298 xlfd-regexp-avgwidth-subnum ;11 299 )) 300 301(defun x-decompose-font-name (pattern) 302 "Decompose PATTERN into XLFD's fields and return vector of the fields. 303The length of the vector is 14. 304 305If PATTERN doesn't conform to XLFD, try to get a full XLFD name from 306X server and use the information of the full name to decompose 307PATTERN. If no full XLFD name is gotten, return nil." 308 (let (xlfd-fields fontname) 309 (if (string-match xlfd-tight-regexp pattern) 310 (let ((i 0)) 311 (setq xlfd-fields (make-vector 14 nil)) 312 (while (< i 14) 313 (aset xlfd-fields i (match-string (1+ i) pattern)) 314 (setq i (1+ i))) 315 xlfd-fields) 316 (setq fontname (condition-case nil 317 (x-resolve-font-name pattern) 318 (error))) 319 (if (and fontname 320 (string-match xlfd-tight-regexp fontname)) 321 ;; We get a full XLFD name. 322 (let ((len (length pattern)) 323 (i 0) 324 l) 325 ;; Setup xlfd-fields by the full XLFD name. Each element 326 ;; should be a cons of matched index and matched string. 327 (setq xlfd-fields (make-vector 14 nil)) 328 (while (< i 14) 329 (aset xlfd-fields i 330 (cons (match-beginning (1+ i)) 331 (match-string (1+ i) fontname))) 332 (setq i (1+ i))) 333 334 ;; Replace wild cards in PATTERN by regexp codes. 335 (setq i 0) 336 (while (< i len) 337 (let ((ch (aref pattern i))) 338 (if (= ch ??) 339 (setq pattern (concat (substring pattern 0 i) 340 "\\(.\\)" 341 (substring pattern (1+ i))) 342 len (+ len 4) 343 i (+ i 4)) 344 (if (= ch ?*) 345 (setq pattern (concat (substring pattern 0 i) 346 "\\(.*\\)" 347 (substring pattern (1+ i))) 348 len (+ len 5) 349 i (+ i 5)) 350 (setq i (1+ i)))))) 351 352 ;; Set each element of xlfd-fields to proper strings. 353 (if (string-match pattern fontname) 354 ;; The regular expression PATTERN matchs the full XLFD 355 ;; name. Set elements that correspond to a wild card 356 ;; in PATTERN to "*", set the other elements to the 357 ;; exact strings in PATTERN. 358 (let ((l (cdr (cdr (match-data))))) 359 (setq i 0) 360 (while (< i 14) 361 (if (or (null l) (< (car (aref xlfd-fields i)) (car l))) 362 (progn 363 (aset xlfd-fields i (cdr (aref xlfd-fields i))) 364 (setq i (1+ i))) 365 (if (< (car (aref xlfd-fields i)) (car (cdr l))) 366 (progn 367 (aset xlfd-fields i "*") 368 (setq i (1+ i))) 369 (setq l (cdr (cdr l))))))) 370 ;; Set each element of xlfd-fields to the exact string 371 ;; in the corresonding fields in full XLFD name. 372 (setq i 0) 373 (while (< i 14) 374 (aset xlfd-fields i (cdr (aref xlfd-fields i))) 375 (setq i (1+ i)))) 376 xlfd-fields))))) 377 378;; Replace consecutive wild-cards (`*') in NAME to one. 379;; Ex. (x-reduce-font-name "-*-*-*-iso8859-1") => "-*-iso8859-1" 380(defsubst x-reduce-font-name (name) 381 (while (string-match "-\\*-\\(\\*-\\)+" name) 382 (setq name (replace-match "-*-" t t name))) 383 name) 384 385(defun x-compose-font-name (fields &optional reduce) 386 "Compose X's fontname from FIELDS. 387FIELDS is a vector of XLFD fields, of length 14. 388If a field is nil, wild-card letter `*' is embedded. 389Optional argument REDUCE exists just for backward compatibility, 390and is always ignored." 391 (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-"))) 392 393 394(defun x-must-resolve-font-name (xlfd-fields) 395 "Like `x-resolve-font-name', but always return a font name. 396XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields. 397If no font matching XLFD-FIELDS is available, successively replace 398parts of the font name pattern with \"*\" until some font is found. 399Value is name of that font." 400 (let ((ascii-font nil) (index 0)) 401 (while (and (null ascii-font) (<= index xlfd-regexp-encoding-subnum)) 402 (let ((pattern (x-compose-font-name xlfd-fields))) 403 (condition-case nil 404 (setq ascii-font (x-resolve-font-name pattern)) 405 (error 406 (message "Warning: no fonts matching `%s' available" pattern) 407 (aset xlfd-fields index "*") 408 (setq index (1+ index)))))) 409 (unless ascii-font 410 (error "No fonts found")) 411 ascii-font)) 412 413 414(defun x-complement-fontset-spec (xlfd-fields fontlist) 415 "Complement FONTLIST for charsets based on XLFD-FIELDS and return it. 416XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields. 417FONTLIST is an alist of charsets vs the corresponding font names. 418 419The fonts are complemented as below. 420 421If FONTLIST doesn't specify a font for ASCII charset, generate a font 422name for the charset from XLFD-FIELDS, and add that information to 423FONTLIST. 424 425If a font specifid for ASCII supports the other charsets (see the 426variable `x-font-name-charset-alist'), add that information to FONTLIST." 427 (let* ((slot (assq 'ascii fontlist)) 428 (ascii-font (cdr slot)) 429 ascii-font-spec) 430 (if ascii-font 431 (setcdr slot (setq ascii-font (x-resolve-font-name ascii-font))) 432 ;; If font for ASCII is not specified, add it. 433 (aset xlfd-fields xlfd-regexp-registry-subnum "iso8859") 434 (aset xlfd-fields xlfd-regexp-encoding-subnum "1") 435 (setq ascii-font (x-must-resolve-font-name xlfd-fields)) 436 (setq fontlist (cons (cons 'ascii ascii-font) fontlist))) 437 438 ;; If the font for ASCII also supports the other charsets, and 439 ;; they are not specified in FONTLIST, add them. 440 (setq xlfd-fields (x-decompose-font-name ascii-font)) 441 (if (not xlfd-fields) 442 (setq ascii-font-spec ascii-font) 443 (setq ascii-font-spec 444 (cons (format "%s-%s" 445 (aref xlfd-fields xlfd-regexp-foundry-subnum) 446 (aref xlfd-fields xlfd-regexp-family-subnum)) 447 (format "%s-%s" 448 (aref xlfd-fields xlfd-regexp-registry-subnum) 449 (aref xlfd-fields xlfd-regexp-encoding-subnum))))) 450 (let ((tail x-font-name-charset-alist) 451 elt) 452 (while tail 453 (setq elt (car tail) tail (cdr tail)) 454 (if (string-match (car elt) ascii-font) 455 (let ((charsets (cdr elt)) 456 charset) 457 (while charsets 458 (setq charset (car charsets) charsets (cdr charsets)) 459 (or (assq charset fontlist) 460 (setq fontlist 461 (cons (cons charset ascii-font-spec) fontlist)))))))) 462 463 fontlist)) 464 465(defun fontset-name-p (fontset) 466 "Return non-nil if FONTSET is valid as fontset name. 467A valid fontset name should conform to XLFD (X Logical Font Description) 468with \"fontset\" in `<CHARSET_REGISTRY>' field." 469 (and (string-match xlfd-tight-regexp fontset) 470 (string= (match-string (1+ xlfd-regexp-registry-subnum) fontset) 471 "fontset"))) 472 473;; Return a list to be appended to `x-fixed-font-alist' when 474;; `mouse-set-font' is called. 475(defun generate-fontset-menu () 476 (let ((fontsets (fontset-list)) 477 fontset-name 478 l) 479 (while fontsets 480 (setq fontset-name (car fontsets) fontsets (cdr fontsets)) 481 (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l))) 482 (cons "Fontset" 483 (sort l (function (lambda (x y) (string< (car x) (car y)))))))) 484 485(defun fontset-plain-name (fontset) 486 "Return a plain and descriptive name of FONTSET." 487 (if (not (setq fontset (query-fontset fontset))) 488 (error "Invalid fontset: %s" fontset)) 489 (let ((xlfd-fields (x-decompose-font-name fontset))) 490 (if xlfd-fields 491 (let ((weight (aref xlfd-fields xlfd-regexp-weight-subnum)) 492 (slant (aref xlfd-fields xlfd-regexp-slant-subnum)) 493 (swidth (aref xlfd-fields xlfd-regexp-swidth-subnum)) 494 (size (aref xlfd-fields xlfd-regexp-pixelsize-subnum)) 495 (charset (aref xlfd-fields xlfd-regexp-registry-subnum)) 496 (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum)) 497 name) 498 (if (not (string= "fontset" charset)) 499 fontset 500 (if (> (string-to-number size) 0) 501 (setq name (format "%s: %s-dot" nickname size)) 502 (setq name nickname)) 503 (cond ((string-match "^medium$" weight) 504 (setq name (concat name " " "medium"))) 505 ((string-match "^bold$\\|^demibold$" weight) 506 (setq name (concat name " " weight)))) 507 (cond ((string-match "^i$" slant) 508 (setq name (concat name " " "italic"))) 509 ((string-match "^o$" slant) 510 (setq name (concat name " " "slant"))) 511 ((string-match "^ri$" slant) 512 (setq name (concat name " " "reverse italic"))) 513 ((string-match "^ro$" slant) 514 (setq name (concat name " " "reverse slant")))) 515 name)) 516 fontset))) 517 518 519(defun create-fontset-from-fontset-spec (fontset-spec 520 &optional style-variant noerror) 521 "Create a fontset from fontset specification string FONTSET-SPEC. 522FONTSET-SPEC is a string of the format: 523 FONTSET-NAME,CHARSET0:FONT0,CHARSET1:FONT1, ... 524Any number of SPACE, TAB, and NEWLINE can be put before and after commas. 525 526Optional 2nd arg exists just for backward compatibility, and is ignored. 527 528If this function attempts to create already existing fontset, an error is 529signaled unless the optional 3rd argument NOERROR is non-nil. 530 531It returns a name of the created fontset." 532 (if (not (string-match "^[^,]+" fontset-spec)) 533 (error "Invalid fontset spec: %s" fontset-spec)) 534 (setq fontset-spec (downcase fontset-spec)) 535 (let ((idx (match-end 0)) 536 (name (match-string 0 fontset-spec)) 537 xlfd-fields charset fontlist ascii-font) 538 (if (query-fontset name) 539 (or noerror 540 (error "Fontset \"%s\" already exists" name)) 541 (setq xlfd-fields (x-decompose-font-name name)) 542 (or xlfd-fields 543 (error "Fontset \"%s\" not conforming to XLFD" name)) 544 545 ;; At first, extract pairs of charset and fontname from FONTSET-SPEC. 546 (while (string-match "[, \t\n]*\\([^:]+\\):[ \t]*\\([^,]+\\)" 547 fontset-spec idx) 548 (setq idx (match-end 0)) 549 (setq charset (intern (match-string 1 fontset-spec))) 550 (if (charsetp charset) 551 (setq fontlist (cons (cons charset (match-string 2 fontset-spec)) 552 fontlist)))) 553 (setq ascii-font (cdr (assq 'ascii fontlist))) 554 555 ;; Complement FONTLIST. 556 (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist)) 557 558 (new-fontset name fontlist) 559 560 ;; Define the short name alias. 561 (if (and (string-match "fontset-.*$" name) 562 (not (assoc name fontset-alias-alist))) 563 (let ((alias (match-string 0 name))) 564 (or (rassoc alias fontset-alias-alist) 565 (setq fontset-alias-alist 566 (cons (cons name alias) fontset-alias-alist))))) 567 568 ;; Define the ASCII font name alias. 569 (or ascii-font 570 (setq ascii-font (cdr (assq 'ascii fontlist)))) 571 (or (rassoc ascii-font fontset-alias-alist) 572 (setq fontset-alias-alist 573 (cons (cons name ascii-font) 574 fontset-alias-alist)))) 575 576 name)) 577 578(defun create-fontset-from-ascii-font (font &optional resolved-font 579 fontset-name) 580 "Create a fontset from an ASCII font FONT. 581 582Optional 2nd arg RESOLVED-FONT is a resolved name of FONT. 583If omitted, `x-resolve-font-name' is called to get the resolved name. 584At this time, if FONT is not available, an error is signaled. 585 586Optional 3rd arg FONTSET-NAME is a string to be used in 587`<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted, 588an appropriate name is generated automatically. 589 590It returns a name of the created fontset." 591 (setq font (downcase font)) 592 (if resolved-font 593 (setq resolved-font (downcase resolved-font)) 594 (setq resolved-font (downcase (x-resolve-font-name font)))) 595 (let ((xlfd (x-decompose-font-name font)) 596 (resolved-xlfd (x-decompose-font-name resolved-font)) 597 fontset fontset-spec) 598 (aset xlfd xlfd-regexp-foundry-subnum nil) 599 (aset xlfd xlfd-regexp-family-subnum nil) 600 (aset xlfd xlfd-regexp-registry-subnum "fontset") 601 (if fontset-name 602 (setq fontset-name (downcase fontset-name)) 603 (setq fontset-name 604 (format "%s_%s_%s" 605 (aref resolved-xlfd xlfd-regexp-registry-subnum) 606 (aref resolved-xlfd xlfd-regexp-encoding-subnum) 607 (aref resolved-xlfd xlfd-regexp-pixelsize-subnum)))) 608 (aset xlfd xlfd-regexp-encoding-subnum fontset-name) 609 (setq fontset (x-compose-font-name xlfd)) 610 (or (query-fontset fontset) 611 (create-fontset-from-fontset-spec (concat fontset ", ascii:" font))))) 612 613 614;; Create standard fontset from 16 dots fonts which are the most widely 615;; installed fonts. Fonts for Chinese-GB, Korean, and Chinese-CNS are 616;; specified here because FAMILY of those fonts are not "fixed" in 617;; many cases. 618(defvar standard-fontset-spec 619 (purecopy "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard, 620 chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*, 621 korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*, 622 chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1, 623 chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2, 624 chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3, 625 chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4, 626 chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5, 627 chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6, 628 chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7") 629 "String of fontset spec of the standard fontset. 630You have the biggest chance to display international characters 631with correct glyphs by using the standard fontset. 632See the documentation of `create-fontset-from-fontset-spec' for the format.") 633 634;; Create fontsets from X resources of the name `fontset-N (class 635;; Fontset-N)' where N is integer 0, 1, ... 636;; The values of the resources the string of the same format as 637;; `standard-fontset-spec'. 638 639(defun create-fontset-from-x-resource () 640 (let ((idx 0) 641 fontset-spec) 642 (while (setq fontset-spec (x-get-resource (format "fontset-%d" idx) 643 (format "Fontset-%d" idx))) 644 (create-fontset-from-fontset-spec fontset-spec t 'noerror) 645 (setq idx (1+ idx))))) 646 647;; 648(provide 'fontset) 649 650;;; arch-tag: bb53e629-0234-403c-950e-551e61554849 651;;; fontset.el ends here 652