/[emacs]/emacs/lisp/international/fontset.el
ViewVC logotype

Diff of /emacs/lisp/international/fontset.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.53.2.15 by handa, Mon Jan 6 01:12:14 2003 UTC revision 1.53.2.16 by handa, Fri Jan 10 07:35:06 2003 UTC
# Line 218  Line 218 
218  ;; Append Unicode fonts.  ;; Append Unicode fonts.
219  ;; This may find fonts with more variants (bold, italic) but which don't cover  ;; This may find fonts with more variants (bold, italic) but which don't cover
220  ;; many characters.  ;; many characters.
221  (set-fontset-font "fontset-default" '(#x00A0 . #xFFFF)  (set-fontset-font "fontset-default" '(0 . #xFFFF)
222                    '(nil . "iso10646-1") nil 'append)                    '(nil . "iso10646-1") nil 'append)
223  ;; These may find fonts that cover many characters but with fewer variants.  ;; These may find fonts that cover many characters but with fewer variants.
224  (set-fontset-font "fontset-default" '(#x00A0 . #xFFFF)  (set-fontset-font "fontset-default" '(0 . #xFFFF)
225                    '("gnu-unifont" . "iso10646-1") nil 'append)                    '("gnu-unifont" . "iso10646-1") nil 'append)
226  (set-fontset-font "fontset-default" '(#x00A0 . #xFFFF)  (set-fontset-font "fontset-default" '(0 . #xFFFF)
227                    '("mutt-clearlyu" . "iso10646-1") nil 'append)                    '("mutt-clearlyu" . "iso10646-1") nil 'append)
228    
229  ;; These are the registered registries/encodings from  ;; These are the registered registries/encodings from
# Line 408  Line 408 
408          ))          ))
409    
410  (defun x-decompose-font-name (pattern)  (defun x-decompose-font-name (pattern)
411    "Decompose PATTERN into XLFD fields and return vector of the fields.    "Decompose PATTERN into XLFD fields and return a vector of the fields.
412  The length of the vector is 12.  The length of the vector is 12.
413    The FOUNDRY and FAMILY fields are concatinated and stored in the first
414  If PATTERN doesn't conform to XLFD, try to get a full XLFD name from  element of the vector.
415  X server and use the information of the full name to decompose  The REGISTRY and ENCODING fields are concatinated and stored in the last
416  PATTERN.  If no full XLFD name is gotten, return nil."  element of the vector.
417    (let (xlfd-fields fontname)  
418      (if (string-match xlfd-tight-regexp pattern)  Return nil if PATTERN doesn't conform to XLFD."
419          (progn    (if (string-match xlfd-tight-regexp pattern)
420            (setq xlfd-fields (make-vector 12 nil))        (let ((xlfd-fields (make-vector 12 nil)))
421            (dotimes (i 12)          (dotimes (i 12)
422              (aset xlfd-fields i (match-string (1+ i) pattern)))            (aset xlfd-fields i (match-string (1+ i) pattern)))
423            (dotimes (i 12)          (dotimes (i 12)
424              (if (string-match "^[*-]+$" (aref xlfd-fields i))            (if (string-match "^[*-]+$" (aref xlfd-fields i))
425                  (aset xlfd-fields i nil)))                (aset xlfd-fields i nil)))
426            xlfd-fields)          xlfd-fields)))
       (setq fontname (condition-case nil  
                          (x-resolve-font-name pattern)  
                        (error)))  
       (if (and fontname  
                (string-match xlfd-tight-regexp fontname))  
           ;; We get a full XLFD name.  
           (let ((len (length pattern))  
                 (i 0)  
                 l)  
             ;; Setup xlfd-fields by the full XLFD name.  Each element  
             ;; should be a cons of matched index and matched string.  
             (setq xlfd-fields (make-vector 12 nil))  
             (dotimes (i 12)  
               (aset xlfd-fields i  
                     (cons (match-beginning (1+ i))  
                           (match-string (1+ i) fontname))))  
   
             ;; Replace wild cards in PATTERN by regexp codes.  
             (setq i 0)  
             (while (< i len)  
               (let ((ch (aref pattern i)))  
                 (if (= ch ??)  
                     (setq pattern (concat (substring pattern 0 i)  
                                           "\\(.\\)"  
                                           (substring pattern (1+ i)))  
                           len (+ len 4)  
                           i (+ i 4))  
                   (if (= ch ?*)  
                       (setq pattern (concat (substring pattern 0 i)  
                                             "\\(.*\\)"  
                                             (substring pattern (1+ i)))  
                             len (+ len 5)  
                             i (+ i 5))  
                     (setq i (1+ i))))))  
   
             ;; Set each element of xlfd-fields to proper strings.  
             (if (string-match pattern fontname)  
                 ;; The regular expression PATTERN matches the full XLFD  
                 ;; name.  Set elements that correspond to a wild card  
                 ;; in PATTERN to nil, set the other elements to the  
                 ;; exact strings in PATTERN.  
                 (let ((l (cdr (cdr (match-data)))))  
                   (setq i 0)  
                   (while (< i 12)  
                     (if (or (null l) (< (car (aref xlfd-fields i)) (car l)))  
                         (progn  
                           (aset xlfd-fields i (cdr (aref xlfd-fields i)))  
                           (setq i (1+ i)))  
                       (if (< (car (aref xlfd-fields i)) (car (cdr l)))  
                           (progn  
                             (aset xlfd-fields i nil)  
                             (setq i (1+ i)))  
                         (setq l (cdr (cdr l)))))))  
               ;; Set each element of xlfd-fields to the exact string  
               ;; in the corresponding fields in full XLFD name.  
               (dotimes (i 12)  
                 (aset xlfd-fields i (cdr (aref xlfd-fields i)))))  
             xlfd-fields)))))  
427    
428  (defun x-compose-font-name (fields &optional reduce)  (defun x-compose-font-name (fields &optional reduce)
429    "Compose X fontname from FIELDS.    "Compose X fontname from FIELDS.
# Line 512  Value is name of that font." Line 454  Value is name of that font."
454    
455    
456  (defun x-complement-fontset-spec (xlfd-fields fontlist)  (defun x-complement-fontset-spec (xlfd-fields fontlist)
457    "Complement FONTLIST for charsets based on XLFD-FIELDS and return it.    "Complement elements of FONTLIST based on XLFD-FIELDS.
458  XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.  XLFD-FIELDS is a vector of XLFD (X Logical Font Description) fields.
459  FONTLIST is an alist of charsets vs the corresponding font names.  FONTLIST is an alist of script names vs the corresponding font names.
   
 The fonts are complemented as below.  
460    
461  At first, if FONTLIST doesn't specify a font for ASCII charset,  The font names are complemented as below.
 generate a font name for the charset from XLFD-FIELDS, and add that  
 information to FONTLIST.  
   
 Then, replace font names with the corresponding XLFD field vectors  
 while substituting default field names for wild cards if they match  
 `xlfd-style-regexp'.  The default field names are decided by  
 XLFD-FIELDS."  
   (let* ((default-spec (vector (aref xlfd-fields xlfd-regexp-family-subnum)  
                                (aref xlfd-fields xlfd-regexp-weight-subnum)  
                                (aref xlfd-fields xlfd-regexp-slant-subnum)  
                                (aref xlfd-fields xlfd-regexp-swidth-subnum)  
                                (aref xlfd-fields xlfd-regexp-adstyle-subnum)  
                                (aref xlfd-fields xlfd-regexp-registry-subnum)))  
          (slot (assq 'ascii fontlist))  
          (ascii-font (cadr slot))  
          xlfd-ascii)  
     (if ascii-font  
         (progn  
           (setq ascii-font (x-resolve-font-name ascii-font))  
           (setcar (cdr slot) ascii-font)  
           (setq xlfd-ascii (x-decompose-font-name ascii-font))  
           (dotimes (i 11)  
             (or (aref xlfd-fields i)  
                 (aset xlfd-fields i (aref xlfd-ascii i)))))  
       ;; If font for ASCII is not specified, add it.  
       (setq xlfd-ascii (copy-sequence xlfd-fields))  
       (aset xlfd-ascii xlfd-regexp-registry-subnum "iso8859-1")  
       (setq ascii-font (x-must-resolve-font-name xlfd-ascii))  
       (setq fontlist (cons (list 'ascii ascii-font) fontlist)))  
462    
463    If a font name matches `xlfd-style-regexp', each field of wild card is
464    replaced by the corresponding fields in XLFD-FIELDS."
465      (let ((default-spec (vector (aref xlfd-fields xlfd-regexp-family-subnum)
466                                  (aref xlfd-fields xlfd-regexp-weight-subnum)
467                                  (aref xlfd-fields xlfd-regexp-slant-subnum)
468                                  (aref xlfd-fields xlfd-regexp-swidth-subnum)
469                                  (aref xlfd-fields xlfd-regexp-adstyle-subnum)
470                                  (aref xlfd-fields xlfd-regexp-registry-subnum))))
471      (dolist (elt fontlist)      (dolist (elt fontlist)
472        (let ((name (cadr elt))        (let ((name (cadr elt))
473              font-spec)              font-spec)
# Line 678  FONTSET-SPEC is a string of the format: Line 597  FONTSET-SPEC is a string of the format:
597          FONTSET-NAME,SCRIPT-NAME0:FONT-NAME0,SCRIPT-NAME1:FONT-NAME1, ...          FONTSET-NAME,SCRIPT-NAME0:FONT-NAME0,SCRIPT-NAME1:FONT-NAME1, ...
598  Any number of SPACE, TAB, and NEWLINE can be put before and after commas.  Any number of SPACE, TAB, and NEWLINE can be put before and after commas.
599    
600  Optional 2nd argument is ignored.  It exists just for backward  When a frame uses the fontset as the `font' parameter, the frame's
601  compatibility.  default font name is derived from FONTSET-NAME by substituting
602    \"iso8859-1\" for the tail part \"fontset-XXX\".  But, if SCRIPT-NAMEn
603    is \"ascii\", use the corresponding FONT-NAMEn as the default font
604    name.
605    
606  If this function attempts to create already existing fontset, error is  Optional 2nd and 3rd arguments are ignored.  They exist just for
607  signaled unless the optional 3rd argument NOERROR is non-nil.  backward compatibility.
608    
609  It returns a name of the created fontset.  It returns a name of the created fontset.
610    
611  For backward compatibility, SCRIPT-NAME may be a charset name, in  For backward compatibility, SCRIPT-NAME may be a charset name, in
612  which case, the corresponding script is decided by the variable  which case, the corresponding script is decided by the variable
613  `charset-script-alist' (which see)."  `charset-script-alist' (which see)."
614    (if (not (string-match "^[^,]+" fontset-spec))    (or (string-match "^[^,]+" fontset-spec)
615        (error "Invalid fontset spec: %s" fontset-spec))        (error "Invalid fontset spec: %s" fontset-spec))
616    (let ((idx (match-end 0))    (let ((idx (match-end 0))
617          (name (match-string 0 fontset-spec))          (name (match-string 0 fontset-spec))
618          xlfd-fields script fontlist ascii-font)          xlfd-fields script fontlist)
619      (if (query-fontset name)      (setq xlfd-fields (x-decompose-font-name name))
620          (or noerror      (or xlfd-fields
621              (error "Fontset \"%s\" already exists" name))          (error "Fontset name \"%s\" not conforming to XLFD" name))
622        (setq xlfd-fields (x-decompose-font-name name))  
623        (or xlfd-fields      ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.
624            (error "Fontset \"%s\" not conforming to XLFD" name))      (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)
625          (setq idx (match-end 0))
626        ;; At first, extract pairs of charset and fontname from FONTSET-SPEC.        (setq script (intern (match-string 1 fontset-spec)))
627        (while (string-match "[, \t\n]*\\([^:]+\\):\\([^,]+\\)" fontset-spec idx)        (if (or (eq script 'ascii)
628          (setq idx (match-end 0))                (memq script (char-table-extra-slot char-script-table 0))
629          (setq script (intern (match-string 1 fontset-spec)))                (setq script (cdr (assq script charset-script-alist))))
630          (if (or (memq script (char-table-extra-slot char-script-table 0))            (setq fontlist (cons (list script (match-string 2 fontset-spec))
631                  (setq script (cdr (assq script charset-script-alist))))                                 fontlist))))
632              (setq fontlist (cons (list script (match-string 2 fontset-spec))  
633                                   fontlist))))      ;; Complement FONTLIST.
634        (setq ascii-font (cadr (assq 'ascii fontlist)))      (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))
   
       ;; Complement FONTLIST.  
       (setq fontlist (x-complement-fontset-spec xlfd-fields fontlist))  
       (setq name (x-compose-font-name xlfd-fields))  
       (new-fontset name fontlist)  
   
       ;; Define the short name alias.  
       (if (and (string-match "fontset-.*$" name)  
                (not (assoc name fontset-alias-alist)))  
           (let ((alias (match-string 0 name)))  
             (or (rassoc alias fontset-alias-alist)  
                 (setq fontset-alias-alist  
                       (cons (cons name alias) fontset-alias-alist)))))  
   
       ;; Define the ASCII font name alias.  
       (or ascii-font  
           (setq ascii-font (cdr (assq 'ascii fontlist))))  
       (or (rassoc ascii-font fontset-alias-alist)  
           (setq fontset-alias-alist  
                 (cons (cons name ascii-font)  
                       fontset-alias-alist))))  
635    
636      name))      ;; Create a fontset.
637        (new-fontset name fontlist)))
638    
639  (defun create-fontset-from-ascii-font (font &optional resolved-font  (defun create-fontset-from-ascii-font (font &optional resolved-font
640                                              fontset-name)                                              fontset-name)

Legend:
Removed from v.1.53.2.15  
changed lines
  Added in v.1.53.2.16

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26