code.delx.au - gnu-emacs/blob - lisp/international/fontset.el

   1 ;;; fontset.el --- Commands for handling fontset.
   2
   3 ;; Copyright (C) 1995, 1997 Electrotechnical Laboratory, JAPAN.
   4 ;; Licensed to the Free Software Foundation.
   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 the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 ;; Set standard 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 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
  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")
  71     (ethiopic . "Ethiopic-Unicode")
  72     (ascii-right-to-left . "ISO8859-1")
  73     (indian-is13194 . "IS13194-Devanagari")
  74     (indian-2-column . "MuleIndian-2")
  75     (indian-1-column . "MuleIndian-1")
  76     (lao . "MuleLao-1")
  77     (tibetan . "MuleTibetan-0")
  78     (tibetan-1-column . "MuleTibetan-1")
  79     ))
  80
  81 (let ((l x-charset-registries))
  82   (while l
  83     (condition-case nil
  84         (put-charset-property (car (car l)) 'x-charset-registry (cdr (car l)))
  85       (error nil))
  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 (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
 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))
 184           ;; We get a full XLFD name.
 185           (let ((len (length pattern))
 186                 (i 0)
 187                 l)
 188             ;; Setup xlfd-fields by the full XLFD name.  Each element
 189             ;; should be a cons of matched index and matched string.
 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)))
 196
 197             ;; Replace wild cards in PATTERN by regexp codes.
 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))))))
 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))))
 239             xlfd-fields)))))
 240
 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
 248 (defun x-compose-font-name (fields &optional reduce)
 249   "Compose X's fontname from FIELDS.
 250 FIELDS is a vector of XLFD fields, the length 14.
 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
 255          (concat "-" (mapconcat (lambda (x) (or x "*")) fields "-"))))
 256     (if reduce
 257         (x-reduce-font-name name)
 258       name)))
 259
 260 (defun register-alternate-fontnames (fontname)
 261   "Register alternate fontnames for FONTNAME in `alternate-fontname-alist'.
 262 When Emacs fails to open FONTNAME, it tries to open an alternate font
 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,
 268   fontname which ignores both style and size specification of FONTNAME.
 269 Emacs tries to open fonts in this order."
 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
 302 ;; Just to avoid compiler waring.  The gloval value is never used.
 303 (defvar resolved-ascii-font nil)
 304
 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.
 308 FONTLIST is an alist of charsets vs the corresponding font names.
 309
 310 Font names for charsets not listed in FONTLIST are generated from
 311 XLFD-FIELDS and a property of x-charset-registry of each charset
 312 automatically.
 313
 314 By side effect, this sets `resolved-ascii-font' to the resolved name
 315 of ASCII font."
 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)
 323     (while charsets
 324       (let ((charset (car charsets)))
 325         (unless (assq charset fontlist)
 326           (let ((registry (get-charset-property charset 'x-charset-registry))
 327                 registry-val encoding-val fontname)
 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 "*"))
 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))
 340             (register-alternate-fontnames fontname))))
 341       (setq charsets (cdr charsets)))
 342
 343     ;; Be sure that ASCII font is available.
 344     (let ((slot (or (assq 'ascii fontlist) (assq 'ascii new-fontlist)))
 345           ascii-font)
 346       (setq ascii-font (condition-case nil
 347                            (x-resolve-font-name (cdr slot))
 348                          (error nil)))
 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
 353             ;; on x-charset-registry in the previous code.
 354             (while l
 355               (if (string-match (car (car l)) ascii-font)
 356                   (let ((charsets (cdr (car l)))
 357                         slot2)
 358                     (while charsets
 359                       (if (and (not (eq (car charsets) 'ascii))
 360                                (setq slot2 (assq (car charsets) new-fontlist)))
 361                           (setcdr slot2 (cdr slot)))
 362                       (setq charsets (cdr charsets)))
 363                     (setq l nil))
 364                 (setq l (cdr l))))
 365             (setq resolved-ascii-font ascii-font)
 366             (append fontlist new-fontlist))))))
 367
 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
 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))
 384       (setq l (cons (list (fontset-plain-name fontset-name) fontset-name) l)))
 385     (cons "Fontset"
 386           (sort l (function (lambda (x y) (string< (car x) (car y))))))))
 387
 388 (defun fontset-plain-name (fontset)
 389   "Return a plain and descriptive name of FONTSET."
 390   (if (not (setq fontset (query-fontset fontset)))
 391       (error "Invalid fontset: %s" fontset))
 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))
 398               (charset (aref xlfd-fields xlfd-regexp-registry-subnum))
 399               (nickname (aref xlfd-fields xlfd-regexp-encoding-subnum))
 400               name)
 401           (if (not (string= "fontset" charset))
 402               fontset
 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"))))
 418             name))
 419       fontset)))
 420
 421 (defvar uninstantiated-fontset-alist nil
 422   "Alist of fontset names vs. information for instantiating them.
 423 Each element has the form (FONTSET STYLE FONTLIST), where
 424 FONTSET is a name of fontset not yet instantiated.
 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.
 428 FONTLIST is an alist of charsets vs font names to be used in FONSET.")
 429
 430 (defconst x-style-funcs-alist
 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
 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
 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)))
 460
 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))))
 467
 468 ;;;###autoload
 469 (defun create-fontset-from-fontset-spec (fontset-spec
 470                                          &optional style-variant noerror)
 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, ...
 474 Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
 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
 483 If this function attempts to create already existing fontset, error is
 484 signaled unless the optional 3rd argument NOERROR is non-nil.
 485
 486 It returns a name of the created fontset."
 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))
 491         fontlist full-fontlist ascii-font resolved-ascii-font charset)
 492     (if (query-fontset name)
 493         (or noerror
 494             (error "Fontset \"%s\" already exists" name))
 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))))
 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)))
 505
 506       ;; If NAME conforms to XLFD, complement FONTLIST for charsets
 507       ;; which are not specified in FONTSET-SPEC.
 508       (let ((fields (x-decompose-font-name name)))
 509         (if fields
 510             (setq full-fontlist (x-complement-fontset-spec fields fontlist))))
 511
 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)))))
 523         (setq fontset-alias-alist
 524               (cons (cons name resolved-ascii-font)
 525                     fontset-alias-alist))
 526         (or (equal ascii-font resolved-ascii-font)
 527             (setq fontset-alias-alist
 528                   (cons (cons name ascii-font)
 529                         fontset-alias-alist)))
 530
 531         ;; At last, handle style variants.
 532         (if (eq style-variant t)
 533             (setq style-variant fontset-default-styles))
 534
 535         (if style-variant
 536             ;; Generate fontset names of style variants and set them
 537             ;; in uninstantiated-fontset-alist.
 538             (let* (nonascii-fontlist
 539                    new-name new-ascii-font style font)
 540               (if ascii-font
 541                   (setq nonascii-fontlist (delete (cons 'ascii ascii-font)
 542                                                   (copy-sequence fontlist)))
 543                 (setq ascii-font (cdr (assq 'ascii full-fontlist))
 544                       nonascii-fontlist fontlist))
 545               (while style-variant
 546                 (setq style (car style-variant))
 547                 (if (symbolp style)
 548                     (setq font nil)
 549                   (setq font (cdr style)
 550                         style (car style)))
 551                 (setq new-name (x-modify-font-name name style))
 552                 (when new-name
 553                   ;; Modify ASCII font name for the style...
 554                   (setq new-ascii-font
 555                         (or font
 556                             (x-modify-font-name resolved-ascii-font style)))
 557                   ;; but leave fonts for the other charsets unmodified
 558                   ;; for the moment.  They are modified for the style
 559                   ;; in instantiate-fontset.
 560                   (setq uninstantiated-fontset-alist
 561                         (cons (list new-name
 562                                     style
 563                                     (cons (cons 'ascii new-ascii-font)
 564                                           nonascii-fontlist))
 565                               uninstantiated-fontset-alist))
 566                   (setq fontset-alias-alist
 567                         (cons (cons new-name new-ascii-font)
 568                               fontset-alias-alist)))
 569                 (setq style-variant (cdr style-variant)))))))
 570     name))
 571
 572 (defun create-fontset-from-ascii-font (font &optional resolved-font
 573                                             fontset-name)
 574   "Create a fontset from an ASCII font FONT.
 575
 576 Optional 1st arg RESOLVED-FONT is a resolved name of FONT.  If
 577 omitted, x-resolve-font-name is called to get the resolved name.  At
 578 this time, if FONT is not available, error is signaled.
 579
 580 Optional 2nd arg FONTSET-NAME is a string to be used in
 581 `<CHARSET_ENCODING>' fields of a new fontset name.  If it is omitted,
 582 an appropriate name is generated automatically.
 583
 584 Style variants of the fontset is created too.  Font names in the
 585 variants are generated automatically from FONT unless X resources
 586 XXX.attributeFont explicitly specify them.
 587
 588 It returns a name of the created fontset."
 589   (or resolved-font
 590       (setq resolved-font (x-resolve-font-name font)))
 591   (let* ((faces (copy-sequence fontset-default-styles))
 592          (styles faces)
 593          (xlfd (x-decompose-font-name font))
 594          (resolved-xlfd  (x-decompose-font-name resolved-font))
 595          face face-font fontset fontset-spec)
 596     (while faces
 597       (setq face (car faces))
 598       (setq face-font (x-get-resource (concat (symbol-name face)
 599                                               ".attributeFont")
 600                                       "Face.AttributeFont"))
 601       (if face-font
 602           (setcar faces (cons face face-font)))
 603       (setq faces (cdr faces)))
 604     (aset xlfd xlfd-regexp-foundry-subnum nil)
 605     (aset xlfd xlfd-regexp-family-subnum nil)
 606     (aset xlfd xlfd-regexp-registry-subnum "fontset")
 607     (or fontset-name
 608         (setq fontset-name
 609               (format "%s_%s_%s"
 610                       (aref resolved-xlfd xlfd-regexp-registry-subnum)
 611                       (aref resolved-xlfd xlfd-regexp-encoding-subnum)
 612                       (aref resolved-xlfd xlfd-regexp-pixelsize-subnum))))
 613     (aset xlfd xlfd-regexp-encoding-subnum fontset-name)
 614     ;; The fontset name should have concrete values in weight and
 615     ;; slant field.
 616     (let ((weight (aref xlfd xlfd-regexp-weight-subnum))
 617           (slant (aref xlfd xlfd-regexp-slant-subnum)))
 618       (if (or (not weight) (string-match "[*?]*" weight))
 619           (aset xlfd xlfd-regexp-weight-subnum
 620                 (aref resolved-xlfd xlfd-regexp-weight-subnum)))
 621       (if (or (not slant) (string-match "[*?]*" slant))
 622           (aset xlfd xlfd-regexp-slant-subnum
 623                 (aref resolved-xlfd xlfd-regexp-slant-subnum))))
 624     (setq fontset (x-compose-font-name xlfd))
 625     (or (query-fontset fontset)
 626         (create-fontset-from-fontset-spec (concat fontset ", ascii:" font)
 627                                           styles))))
 628
 629 (defun instantiate-fontset (fontset)
 630   "Make FONTSET be ready to use.
 631 FONTSET should be in the variable `uninstantiated-fontset-alist' in advance.
 632 Return FONTSET if it is created successfully, else return nil."
 633   (let ((fontset-data (assoc fontset uninstantiated-fontset-alist)))
 634     (when fontset-data
 635       (setq uninstantiated-fontset-alist
 636             (delete fontset-data uninstantiated-fontset-alist))
 637
 638       (let* ((fields (x-decompose-font-name fontset))
 639              (style (nth 1 fontset-data))
 640              (fontlist (x-complement-fontset-spec fields (nth 2 fontset-data)))
 641              (font (cdr (assq 'ascii fontlist))))
 642         ;; If ASCII font is available, instantiate this fontset.
 643         (when font
 644           (let ((new-fontlist (list (cons 'ascii font))))
 645             ;; Fonts for non-ascii charsets should be modified for
 646             ;; this style now.
 647             (while fontlist
 648               (setq font (cdr (car fontlist)))
 649               (or (eq (car (car fontlist)) 'ascii)
 650                   (setq new-fontlist
 651                         (cons (cons (car (car fontlist))
 652                                     (x-modify-font-name font style))
 653                               new-fontlist)))
 654               (setq fontlist (cdr fontlist)))
 655             (new-fontset fontset new-fontlist)
 656             fontset))))))
 657
 658 (defun resolve-fontset-name (pattern)
 659   "Return a fontset name matching PATTERN."
 660   (let ((fontset (car (rassoc pattern fontset-alias-alist))))
 661     (or fontset (setq fontset pattern))
 662     (if (assoc fontset uninstantiated-fontset-alist)
 663         (instantiate-fontset fontset)
 664       (query-fontset fontset))))
 665 \f
 666 ;; Create standard fontset from 16 dots fonts which are the most widely
 667 ;; installed fonts.  Fonts for Chinese-GB, Korean, and Chinese-CNS are
 668 ;; specified here because FAMILY of those fonts are not "fixed" in
 669 ;; many cases.
 670 (defvar standard-fontset-spec
 671   "-*-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-standard,
 672         chinese-gb2312:-*-medium-r-normal-*-16-*-gb2312*-*,
 673         korean-ksc5601:-*-medium-r-normal-*-16-*-ksc5601*-*,
 674         chinese-cns11643-1:-*-medium-r-normal-*-16-*-cns11643*-1,
 675         chinese-cns11643-2:-*-medium-r-normal-*-16-*-cns11643*-2,
 676         chinese-cns11643-3:-*-medium-r-normal-*-16-*-cns11643*-3,
 677         chinese-cns11643-4:-*-medium-r-normal-*-16-*-cns11643*-4,
 678         chinese-cns11643-5:-*-medium-r-normal-*-16-*-cns11643*-5,
 679         chinese-cns11643-6:-*-medium-r-normal-*-16-*-cns11643*-6,
 680         chinese-cns11643-7:-*-medium-r-normal-*-16-*-cns11643*-7"
 681   "String of fontset spec of the standard fontset.
 682 You have the biggest chance to display international characters
 683 with correct glyphs by using the standard fontset.
 684 See the documentation of `create-fontset-from-fontset-spec' for the format.")
 685
 686 ;; Create fontsets from X resources of the name `fontset-N (class
 687 ;; Fontset-N)' where N is integer 0, 1, ...
 688 ;; The values of the resources the string of the same format as
 689 ;; `standard-fontset-spec'.
 690
 691 (defun create-fontset-from-x-resource ()
 692   (let ((idx 0)
 693         fontset-spec)
 694     (while (setq fontset-spec (x-get-resource (concat "fontset-" idx)
 695                                               (concat "Fontset-" idx)))
 696       (create-fontset-from-fontset-spec fontset-spec t 'noerror)
 697       (setq idx (1+ idx)))))
 698
 699 (defsubst fontset-list ()
 700   "Returns a list of all defined fontset names."
 701   (mapcar 'car global-fontset-alist))
 702
 703 ;;
 704 (provide 'fontset)
 705
 706 ;;; fontset.el ends here