src/xfont.c

   1 /* xfont.c -- X core font driver.
   2    Copyright (C) 2006-2012 Free Software Foundation, Inc.
   3    Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011
   4      National Institute of Advanced Industrial Science and Technology (AIST)
   5      Registration Number H13PRO009
   6
   7 This file is part of GNU Emacs.
   8
   9 GNU Emacs is free software: you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation, either version 3 of the License, or
  12 (at your option) any later version.
  13
  14 GNU Emacs is distributed in the hope that it will be useful,
  15 but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 GNU General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  21
  22 #include <config.h>
  23 #include <stdio.h>
  24 #include <setjmp.h>
  25 #include <X11/Xlib.h>
  26
  27 #include "lisp.h"
  28 #include "dispextern.h"
  29 #include "xterm.h"
  30 #include "frame.h"
  31 #include "blockinput.h"
  32 #include "character.h"
  33 #include "charset.h"
  34 #include "fontset.h"
  35 #include "font.h"
  36 #include "ccl.h"
  37
  38 \f
  39 /* X core font driver.  */
  40
  41 struct xfont_info
  42 {
  43   struct font font;
  44   Display *display;
  45   XFontStruct *xfont;
  46 };
  47
  48 /* Prototypes of support functions.  */
  49
  50 static XCharStruct *xfont_get_pcm (XFontStruct *, XChar2b *);
  51
  52 /* Get metrics of character CHAR2B in XFONT.  Value is null if CHAR2B
  53    is not contained in the font.  */
  54
  55 static XCharStruct *
  56 xfont_get_pcm (XFontStruct *xfont, XChar2b *char2b)
  57 {
  58   /* The result metric information.  */
  59   XCharStruct *pcm = NULL;
  60
  61   eassert (xfont && char2b);
  62
  63   if (xfont->per_char != NULL)
  64     {
  65       if (xfont->min_byte1 == 0 && xfont->max_byte1 == 0)
  66         {
  67           /* min_char_or_byte2 specifies the linear character index
  68              corresponding to the first element of the per_char array,
  69              max_char_or_byte2 is the index of the last character.  A
  70              character with non-zero CHAR2B->byte1 is not in the font.
  71              A character with byte2 less than min_char_or_byte2 or
  72              greater max_char_or_byte2 is not in the font.  */
  73           if (char2b->byte1 == 0
  74               && char2b->byte2 >= xfont->min_char_or_byte2
  75               && char2b->byte2 <= xfont->max_char_or_byte2)
  76             pcm = xfont->per_char + char2b->byte2 - xfont->min_char_or_byte2;
  77         }
  78       else
  79         {
  80           /* If either min_byte1 or max_byte1 are nonzero, both
  81              min_char_or_byte2 and max_char_or_byte2 are less than
  82              256, and the 2-byte character index values corresponding
  83              to the per_char array element N (counting from 0) are:
  84
  85              byte1 = N/D + min_byte1
  86              byte2 = N\D + min_char_or_byte2
  87
  88              where:
  89
  90              D = max_char_or_byte2 - min_char_or_byte2 + 1
  91              / = integer division
  92              \ = integer modulus  */
  93           if (char2b->byte1 >= xfont->min_byte1
  94               && char2b->byte1 <= xfont->max_byte1
  95               && char2b->byte2 >= xfont->min_char_or_byte2
  96               && char2b->byte2 <= xfont->max_char_or_byte2)
  97             pcm = (xfont->per_char
  98                    + ((xfont->max_char_or_byte2 - xfont->min_char_or_byte2 + 1)
  99                       * (char2b->byte1 - xfont->min_byte1))
 100                    + (char2b->byte2 - xfont->min_char_or_byte2));
 101         }
 102     }
 103   else
 104     {
 105       /* If the per_char pointer is null, all glyphs between the first
 106          and last character indexes inclusive have the same
 107          information, as given by both min_bounds and max_bounds.  */
 108       if (char2b->byte2 >= xfont->min_char_or_byte2
 109           && char2b->byte2 <= xfont->max_char_or_byte2)
 110         pcm = &xfont->max_bounds;
 111     }
 112
 113   return ((pcm == NULL
 114            || (pcm->width == 0 && (pcm->rbearing - pcm->lbearing) == 0))
 115           ? NULL : pcm);
 116 }
 117
 118 static Lisp_Object xfont_get_cache (FRAME_PTR);
 119 static Lisp_Object xfont_list (Lisp_Object, Lisp_Object);
 120 static Lisp_Object xfont_match (Lisp_Object, Lisp_Object);
 121 static Lisp_Object xfont_list_family (Lisp_Object);
 122 static Lisp_Object xfont_open (FRAME_PTR, Lisp_Object, int);
 123 static void xfont_close (FRAME_PTR, struct font *);
 124 static int xfont_prepare_face (FRAME_PTR, struct face *);
 125 static int xfont_has_char (Lisp_Object, int);
 126 static unsigned xfont_encode_char (struct font *, int);
 127 static int xfont_text_extents (struct font *, unsigned *, int,
 128                                struct font_metrics *);
 129 static int xfont_draw (struct glyph_string *, int, int, int, int, int);
 130 static int xfont_check (FRAME_PTR, struct font *);
 131
 132 struct font_driver xfont_driver =
 133   {
 134     LISP_INITIALLY_ZERO,        /* Qx */
 135     0,                          /* case insensitive */
 136     xfont_get_cache,
 137     xfont_list,
 138     xfont_match,
 139     xfont_list_family,
 140     NULL,
 141     xfont_open,
 142     xfont_close,
 143     xfont_prepare_face,
 144     NULL,
 145     xfont_has_char,
 146     xfont_encode_char,
 147     xfont_text_extents,
 148     xfont_draw,
 149     NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL,
 150     xfont_check,
 151     NULL, /* get_variation_glyphs */
 152     NULL, /* filter_properties */
 153   };
 154
 155 static Lisp_Object
 156 xfont_get_cache (FRAME_PTR f)
 157 {
 158   Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
 159
 160   return (dpyinfo->name_list_element);
 161 }
 162
 163 static int
 164 compare_font_names (const void *name1, const void *name2)
 165 {
 166   char *const *n1 = name1;
 167   char *const *n2 = name2;
 168   return xstrcasecmp (*n1, *n2);
 169 }
 170
 171 /* Decode XLFD as iso-8859-1 into OUTPUT, and return the byte length
 172    of the decoding result.  LEN is the byte length of XLFD, or -1 if
 173    XLFD is NULL terminated.  The caller must assure that OUTPUT is at
 174    least twice (plus 1) as large as XLFD.  */
 175
 176 static ptrdiff_t
 177 xfont_decode_coding_xlfd (char *xlfd, int len, char *output)
 178 {
 179   char *p0 = xlfd, *p1 = output;
 180   int c;
 181
 182   while (*p0)
 183     {
 184       c = *(unsigned char *) p0++;
 185       p1 += CHAR_STRING (c, (unsigned char *) p1);
 186       if (--len == 0)
 187         break;
 188     }
 189   *p1 = 0;
 190   return (p1 - output);
 191 }
 192
 193 /* Encode XLFD from UTF-8 to iso-8859-1 destructively, and return the
 194    resulting byte length.  If XLFD contains unencodable character,
 195    return -1.  */
 196
 197 static int
 198 xfont_encode_coding_xlfd (char *xlfd)
 199 {
 200   const unsigned char *p0 = (unsigned char *) xlfd;
 201   unsigned char *p1 = (unsigned char *) xlfd;
 202   int len = 0;
 203
 204   while (*p0)
 205     {
 206       int c = STRING_CHAR_ADVANCE (p0);
 207
 208       if (c >= 0x100)
 209         return -1;
 210       *p1++ = c;
 211       len++;
 212     }
 213   *p1 = 0;
 214   return len;
 215 }
 216
 217 /* Check if CHARS (cons or vector) is supported by XFONT whose
 218    encoding charset is ENCODING (XFONT is NULL) or by a font whose
 219    registry corresponds to ENCODING and REPERTORY.
 220    Return 1 if supported, return 0 otherwise.  */
 221
 222 static int
 223 xfont_chars_supported (Lisp_Object chars, XFontStruct *xfont,
 224                        struct charset *encoding, struct charset *repertory)
 225 {
 226   struct charset *charset = repertory ? repertory : encoding;
 227
 228   if (CONSP (chars))
 229     {
 230       for (; CONSP (chars); chars = XCDR (chars))
 231         {
 232           int c = XINT (XCAR (chars));
 233           unsigned code = ENCODE_CHAR (charset, c);
 234           XChar2b char2b;
 235
 236           if (code == CHARSET_INVALID_CODE (charset))
 237             break;
 238           if (! xfont)
 239             continue;
 240           if (code >= 0x10000)
 241             break;
 242           char2b.byte1 = code >> 8;
 243           char2b.byte2 = code & 0xFF;
 244           if (! xfont_get_pcm (xfont, &char2b))
 245             break;
 246         }
 247       return (NILP (chars));
 248     }
 249   else if (VECTORP (chars))
 250     {
 251       ptrdiff_t i;
 252
 253       for (i = ASIZE (chars) - 1; i >= 0; i--)
 254         {
 255           int c = XINT (AREF (chars, i));
 256           unsigned code = ENCODE_CHAR (charset, c);
 257           XChar2b char2b;
 258
 259           if (code == CHARSET_INVALID_CODE (charset))
 260             continue;
 261           if (! xfont)
 262             break;
 263           if (code >= 0x10000)
 264             continue;
 265           char2b.byte1 = code >> 8;
 266           char2b.byte2 = code & 0xFF;
 267           if (xfont_get_pcm (xfont, &char2b))
 268             break;
 269         }
 270       return (i >= 0);
 271     }
 272   return 0;
 273 }
 274
 275 /* A hash table recoding which font supports which scripts.  Each key
 276    is a vector of characteristic font properties FOUNDRY to WIDTH and
 277    ADDSTYLE, and each value is a list of script symbols.
 278
 279    We assume that fonts that have the same value in the above
 280    properties supports the same set of characters on all displays.  */
 281
 282 static Lisp_Object xfont_scripts_cache;
 283
 284 /* Re-usable vector to store characteristic font properties.   */
 285 static Lisp_Object xfont_scratch_props;
 286
 287 /* Return a list of scripts supported by the font of FONTNAME whose
 288    characteristic properties are in PROPS and whose encoding charset
 289    is ENCODING.  A caller must call BLOCK_INPUT in advance.  */
 290
 291 static Lisp_Object
 292 xfont_supported_scripts (Display *display, char *fontname, Lisp_Object props,
 293                          struct charset *encoding)
 294 {
 295   Lisp_Object scripts;
 296
 297   /* Two special cases to avoid opening rather big fonts.  */
 298   if (EQ (AREF (props, 2), Qja))
 299     return Fcons (intern ("kana"), Fcons (intern ("han"), Qnil));
 300   if (EQ (AREF (props, 2), Qko))
 301     return Fcons (intern ("hangul"), Qnil);
 302   scripts = Fgethash (props, xfont_scripts_cache, Qt);
 303   if (EQ (scripts, Qt))
 304     {
 305       XFontStruct *xfont;
 306       Lisp_Object val;
 307
 308       scripts = Qnil;
 309       xfont = XLoadQueryFont (display, fontname);
 310       if (xfont)
 311         {
 312           if (xfont->per_char)
 313             {
 314               for (val = Vscript_representative_chars; CONSP (val);
 315                    val = XCDR (val))
 316                 if (CONSP (XCAR (val)) && SYMBOLP (XCAR (XCAR (val))))
 317                   {
 318                     Lisp_Object script = XCAR (XCAR (val));
 319                     Lisp_Object chars = XCDR (XCAR (val));
 320
 321                     if (xfont_chars_supported (chars, xfont, encoding, NULL))
 322                       scripts = Fcons (script, scripts);
 323                   }
 324             }
 325           XFreeFont (display, xfont);
 326         }
 327       if (EQ (AREF (props, 3), Qiso10646_1)
 328           && NILP (Fmemq (Qlatin, scripts)))
 329         scripts = Fcons (Qlatin, scripts);
 330       Fputhash (Fcopy_sequence (props), scripts, xfont_scripts_cache);
 331     }
 332   return scripts;
 333 }
 334
 335 static Lisp_Object
 336 xfont_list_pattern (Display *display, const char *pattern,
 337                     Lisp_Object registry, Lisp_Object script)
 338 {
 339   Lisp_Object list = Qnil;
 340   Lisp_Object chars = Qnil;
 341   struct charset *encoding, *repertory = NULL;
 342   int i, limit, num_fonts;
 343   char **names;
 344   /* Large enough to decode the longest XLFD (255 bytes). */
 345   char buf[512];
 346
 347   if (! NILP (registry)
 348       && font_registry_charsets (registry, &encoding, &repertory) < 0)
 349     /* Unknown REGISTRY, not supported.  */
 350     return Qnil;
 351   if (! NILP (script))
 352     {
 353       chars = assq_no_quit (script, Vscript_representative_chars);
 354       if (NILP (chars))
 355         /* We can't tell whether or not a font supports SCRIPT.  */
 356         return Qnil;
 357       chars = XCDR (chars);
 358       if (repertory)
 359         {
 360           if (! xfont_chars_supported (chars, NULL, encoding, repertory))
 361             return Qnil;
 362           script = Qnil;
 363         }
 364     }
 365
 366   BLOCK_INPUT;
 367   x_catch_errors (display);
 368
 369   for (limit = 512; ; limit *= 2)
 370     {
 371       names = XListFonts (display, pattern, limit, &num_fonts);
 372       if (x_had_errors_p (display))
 373         {
 374           /* This error is perhaps due to insufficient memory on X
 375              server.  Let's just ignore it.  */
 376           x_clear_errors (display);
 377           num_fonts = 0;
 378           break;
 379         }
 380       if (num_fonts < limit)
 381         break;
 382       XFreeFontNames (names);
 383     }
 384
 385   if (num_fonts > 0)
 386     {
 387       char **indices = alloca (sizeof (char *) * num_fonts);
 388       Lisp_Object *props = XVECTOR (xfont_scratch_props)->contents;
 389       Lisp_Object scripts = Qnil;
 390
 391       for (i = 0; i < ASIZE (xfont_scratch_props); i++)
 392         ASET (xfont_scratch_props, i, Qnil);
 393       for (i = 0; i < num_fonts; i++)
 394         indices[i] = names[i];
 395       qsort (indices, num_fonts, sizeof (char *), compare_font_names);
 396
 397       for (i = 0; i < num_fonts; i++)
 398         {
 399           ptrdiff_t len;
 400           Lisp_Object entity;
 401
 402           if (i > 0 && xstrcasecmp (indices[i - 1], indices[i]) == 0)
 403             continue;
 404           entity = font_make_entity ();
 405           len = xfont_decode_coding_xlfd (indices[i], -1, buf);
 406           if (font_parse_xlfd (buf, len, entity) < 0)
 407             continue;
 408           ASET (entity, FONT_TYPE_INDEX, Qx);
 409           /* Avoid auto-scaled fonts.  */
 410           if (INTEGERP (AREF (entity, FONT_DPI_INDEX))
 411               && INTEGERP (AREF (entity, FONT_AVGWIDTH_INDEX))
 412               && XINT (AREF (entity, FONT_DPI_INDEX)) != 0
 413               && XINT (AREF (entity, FONT_AVGWIDTH_INDEX)) == 0)
 414             continue;
 415           /* Avoid not-allowed scalable fonts.  */
 416           if (NILP (Vscalable_fonts_allowed))
 417             {
 418               int size = 0;
 419
 420               if (INTEGERP (AREF (entity, FONT_SIZE_INDEX)))
 421                 size = XINT (AREF (entity, FONT_SIZE_INDEX));
 422               else if (FLOATP (AREF (entity, FONT_SIZE_INDEX)))
 423                 size = XFLOAT_DATA (AREF (entity, FONT_SIZE_INDEX));
 424               if (size == 0)
 425                 continue;
 426             }
 427           else if (CONSP (Vscalable_fonts_allowed))
 428             {
 429               Lisp_Object tail, elt;
 430
 431               for (tail = Vscalable_fonts_allowed; CONSP (tail);
 432                    tail = XCDR (tail))
 433                 {
 434                   elt = XCAR (tail);
 435                   if (STRINGP (elt)
 436                       && fast_c_string_match_ignore_case (elt, indices[i],
 437                                                           len) >= 0)
 438                     break;
 439                 }
 440               if (! CONSP (tail))
 441                 continue;
 442             }
 443
 444           /* Avoid fonts of invalid registry.  */
 445           if (NILP (AREF (entity, FONT_REGISTRY_INDEX)))
 446             continue;
 447
 448           /* Update encoding and repertory if necessary.  */
 449           if (! EQ (registry, AREF (entity, FONT_REGISTRY_INDEX)))
 450             {
 451               registry = AREF (entity, FONT_REGISTRY_INDEX);
 452               if (font_registry_charsets (registry, &encoding, &repertory) < 0)
 453                 encoding = NULL;
 454             }
 455           if (! encoding)
 456             /* Unknown REGISTRY, not supported.  */
 457             continue;
 458           if (repertory)
 459             {
 460               if (NILP (script)
 461                   || xfont_chars_supported (chars, NULL, encoding, repertory))
 462                 list = Fcons (entity, list);
 463               continue;
 464             }
 465           if (memcmp (props, aref_addr (entity, FONT_FOUNDRY_INDEX),
 466                       word_size * 7)
 467               || ! EQ (AREF (entity, FONT_SPACING_INDEX), props[7]))
 468             {
 469               vcopy (xfont_scratch_props, 0,
 470                      aref_addr (entity, FONT_FOUNDRY_INDEX), 7);
 471               ASET (xfont_scratch_props, 7, AREF (entity, FONT_SPACING_INDEX));
 472               scripts = xfont_supported_scripts (display, indices[i],
 473                                                  xfont_scratch_props, encoding);
 474             }
 475           if (NILP (script)
 476               || ! NILP (Fmemq (script, scripts)))
 477             list = Fcons (entity, list);
 478         }
 479       XFreeFontNames (names);
 480     }
 481
 482   x_uncatch_errors ();
 483   UNBLOCK_INPUT;
 484
 485   FONT_ADD_LOG ("xfont-list", build_string (pattern), list);
 486   return list;
 487 }
 488
 489 static Lisp_Object
 490 xfont_list (Lisp_Object frame, Lisp_Object spec)
 491 {
 492   FRAME_PTR f = XFRAME (frame);
 493   Display *display = FRAME_X_DISPLAY_INFO (f)->display;
 494   Lisp_Object registry, list, val, extra, script;
 495   int len;
 496   /* Large enough to contain the longest XLFD (255 bytes) in UTF-8.  */
 497   char name[512];
 498
 499   extra = AREF (spec, FONT_EXTRA_INDEX);
 500   if (CONSP (extra))
 501     {
 502       val = assq_no_quit (QCotf, extra);
 503       if (! NILP (val))
 504         return Qnil;
 505       val = assq_no_quit (QClang, extra);
 506       if (! NILP (val))
 507         return Qnil;
 508     }
 509
 510   registry = AREF (spec, FONT_REGISTRY_INDEX);
 511   len = font_unparse_xlfd (spec, 0, name, 512);
 512   if (len < 0 || (len = xfont_encode_coding_xlfd (name)) < 0)
 513     return Qnil;
 514
 515   val = assq_no_quit (QCscript, extra);
 516   script = CDR (val);
 517   list = xfont_list_pattern (display, name, registry, script);
 518   if (NILP (list) && NILP (registry))
 519     {
 520       /* Try iso10646-1 */
 521       char *r = name + len - 9; /* 9 == strlen (iso8859-1) */
 522
 523       if (r - name + 10 < 256)  /* 10 == strlen (iso10646-1) */
 524         {
 525           strcpy (r, "iso10646-1");
 526           list = xfont_list_pattern (display, name, Qiso10646_1, script);
 527         }
 528     }
 529   if (NILP (list) && ! NILP (registry))
 530     {
 531       /* Try alternate registries.  */
 532       Lisp_Object alter;
 533
 534       if ((alter = Fassoc (SYMBOL_NAME (registry),
 535                            Vface_alternative_font_registry_alist),
 536            CONSP (alter)))
 537         {
 538           /* Pointer to REGISTRY-ENCODING field.  */
 539           char *r = name + len - SBYTES (SYMBOL_NAME (registry));
 540
 541           for (alter = XCDR (alter); CONSP (alter); alter = XCDR (alter))
 542             if (STRINGP (XCAR (alter))
 543                 && ((r - name) + SBYTES (XCAR (alter))) < 256)
 544               {
 545                 strcpy (r, SSDATA (XCAR (alter)));
 546                 list = xfont_list_pattern (display, name, registry, script);
 547                 if (! NILP (list))
 548                   break;
 549               }
 550         }
 551     }
 552   if (NILP (list))
 553     {
 554       /* Try alias.  */
 555       val = assq_no_quit (QCname, AREF (spec, FONT_EXTRA_INDEX));
 556       if (CONSP (val) && STRINGP (XCDR (val)) && SBYTES (XCDR (val)) < 512)
 557         {
 558           memcpy (name, SDATA (XCDR (val)), SBYTES (XCDR (val)) + 1);
 559           if (xfont_encode_coding_xlfd (name) < 0)
 560             return Qnil;
 561           list = xfont_list_pattern (display, name, registry, script);
 562         }
 563     }
 564
 565   return list;
 566 }
 567
 568 static Lisp_Object
 569 xfont_match (Lisp_Object frame, Lisp_Object spec)
 570 {
 571   FRAME_PTR f = XFRAME (frame);
 572   Display *display = FRAME_X_DISPLAY_INFO (f)->display;
 573   Lisp_Object extra, val, entity;
 574   char name[512];
 575   XFontStruct *xfont;
 576   unsigned long value;
 577
 578   extra = AREF (spec, FONT_EXTRA_INDEX);
 579   val = assq_no_quit (QCname, extra);
 580   if (! CONSP (val) || ! STRINGP (XCDR (val)))
 581     {
 582       if (font_unparse_xlfd (spec, 0, name, 512) < 0)
 583         return Qnil;
 584     }
 585   else if (SBYTES (XCDR (val)) < 512)
 586     memcpy (name, SDATA (XCDR (val)), SBYTES (XCDR (val)) + 1);
 587   else
 588     return Qnil;
 589   if (xfont_encode_coding_xlfd (name) < 0)
 590     return Qnil;
 591
 592   BLOCK_INPUT;
 593   entity = Qnil;
 594   xfont = XLoadQueryFont (display, name);
 595   if (xfont)
 596     {
 597       if (XGetFontProperty (xfont, XA_FONT, &value))
 598         {
 599           char *s;
 600
 601           s = (char *) XGetAtomName (display, (Atom) value);
 602
 603           /* If DXPC (a Differential X Protocol Compressor)
 604              Ver.3.7 is running, XGetAtomName will return null
 605              string.  We must avoid such a name.  */
 606           if (*s)
 607             {
 608               ptrdiff_t len;
 609               entity = font_make_entity ();
 610               ASET (entity, FONT_TYPE_INDEX, Qx);
 611               len = xfont_decode_coding_xlfd (s, -1, name);
 612               if (font_parse_xlfd (name, len, entity) < 0)
 613                 entity = Qnil;
 614             }
 615           XFree (s);
 616         }
 617       XFreeFont (display, xfont);
 618     }
 619   UNBLOCK_INPUT;
 620
 621   FONT_ADD_LOG ("xfont-match", spec, entity);
 622   return entity;
 623 }
 624
 625 static Lisp_Object
 626 xfont_list_family (Lisp_Object frame)
 627 {
 628   FRAME_PTR f = XFRAME (frame);
 629   Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
 630   char **names;
 631   int num_fonts, i;
 632   Lisp_Object list;
 633   char *last_family IF_LINT (= 0);
 634   int last_len;
 635
 636   BLOCK_INPUT;
 637   x_catch_errors (dpyinfo->display);
 638   names = XListFonts (dpyinfo->display, "-*-*-*-*-*-*-*-*-*-*-*-*-*-*",
 639                       0x8000, &num_fonts);
 640   if (x_had_errors_p (dpyinfo->display))
 641     {
 642       /* This error is perhaps due to insufficient memory on X server.
 643          Let's just ignore it.  */
 644       x_clear_errors (dpyinfo->display);
 645       num_fonts = 0;
 646     }
 647
 648   list = Qnil;
 649   for (i = 0, last_len = 0; i < num_fonts; i++)
 650     {
 651       char *p0 = names[i], *p1, buf[512];
 652       Lisp_Object family;
 653       int decoded_len;
 654
 655       p0++;                     /* skip the leading '-' */
 656       while (*p0 && *p0 != '-') p0++; /* skip foundry */
 657       if (! *p0)
 658         continue;
 659       p1 = ++p0;
 660       while (*p1 && *p1 != '-') p1++; /* find the end of family */
 661       if (! *p1 || p1 == p0)
 662         continue;
 663       if (last_len == p1 - p0
 664           && memcmp (last_family, p0, last_len) == 0)
 665         continue;
 666       last_len = p1 - p0;
 667       last_family = p0;
 668
 669       decoded_len = xfont_decode_coding_xlfd (p0, last_len, buf);
 670       family = font_intern_prop (p0, decoded_len, 1);
 671       if (NILP (assq_no_quit (family, list)))
 672         list = Fcons (family, list);
 673     }
 674
 675   XFreeFontNames (names);
 676   x_uncatch_errors ();
 677   UNBLOCK_INPUT;
 678
 679   return list;
 680 }
 681
 682 static Lisp_Object
 683 xfont_open (FRAME_PTR f, Lisp_Object entity, int pixel_size)
 684 {
 685   Display_Info *dpyinfo = FRAME_X_DISPLAY_INFO (f);
 686   Display *display = dpyinfo->display;
 687   char name[512];
 688   int len;
 689   unsigned long value;
 690   Lisp_Object registry;
 691   struct charset *encoding, *repertory;
 692   Lisp_Object font_object, fullname;
 693   struct font *font;
 694   XFontStruct *xfont;
 695
 696   /* At first, check if we know how to encode characters for this
 697      font.  */
 698   registry = AREF (entity, FONT_REGISTRY_INDEX);
 699   if (font_registry_charsets (registry, &encoding, &repertory) < 0)
 700     {
 701       FONT_ADD_LOG ("  x:unknown registry", registry, Qnil);
 702       return Qnil;
 703     }
 704
 705   if (XINT (AREF (entity, FONT_SIZE_INDEX)) != 0)
 706     pixel_size = XINT (AREF (entity, FONT_SIZE_INDEX));
 707   else if (pixel_size == 0)
 708     {
 709       if (FRAME_FONT (f))
 710         pixel_size = FRAME_FONT (f)->pixel_size;
 711       else
 712         pixel_size = 14;
 713     }
 714   len = font_unparse_xlfd (entity, pixel_size, name, 512);
 715   if (len <= 0 || (len = xfont_encode_coding_xlfd (name)) < 0)
 716     {
 717       FONT_ADD_LOG ("  x:unparse failed", entity, Qnil);
 718       return Qnil;
 719     }
 720
 721   BLOCK_INPUT;
 722   x_catch_errors (display);
 723   xfont = XLoadQueryFont (display, name);
 724   if (x_had_errors_p (display))
 725     {
 726       /* This error is perhaps due to insufficient memory on X server.
 727          Let's just ignore it.  */
 728       x_clear_errors (display);
 729       xfont = NULL;
 730     }
 731   else if (! xfont)
 732     {
 733       /* Some version of X lists:
 734            -misc-fixed-medium-r-normal--20-*-75-75-c-100-iso8859-1
 735            -misc-fixed-medium-r-normal--20-*-100-100-c-100-iso8859-1
 736          but can open only:
 737            -misc-fixed-medium-r-normal--20-*-100-100-c-100-iso8859-1
 738          and
 739            -misc-fixed-medium-r-normal--20-*-*-*-c-100-iso8859-1
 740          So, we try again with wildcards in RESX and RESY.  */
 741       Lisp_Object temp;
 742
 743       temp = copy_font_spec (entity);
 744       ASET (temp, FONT_DPI_INDEX, Qnil);
 745       len = font_unparse_xlfd (temp, pixel_size, name, 512);
 746       if (len <= 0 || (len = xfont_encode_coding_xlfd (name)) < 0)
 747         {
 748           FONT_ADD_LOG ("  x:unparse failed", temp, Qnil);
 749           return Qnil;
 750         }
 751       xfont = XLoadQueryFont (display, name);
 752       if (x_had_errors_p (display))
 753         {
 754           /* This error is perhaps due to insufficient memory on X server.
 755              Let's just ignore it.  */
 756           x_clear_errors (display);
 757           xfont = NULL;
 758         }
 759     }
 760   fullname = Qnil;
 761   /* Try to get the full name of FONT.  */
 762   if (xfont && XGetFontProperty (xfont, XA_FONT, &value))
 763     {
 764       char *p0, *p;
 765       int dashes = 0;
 766
 767       p0 = p = (char *) XGetAtomName (FRAME_X_DISPLAY (f), (Atom) value);
 768       /* Count the number of dashes in the "full name".
 769          If it is too few, this isn't really the font's full name,
 770          so don't use it.
 771          In X11R4, the fonts did not come with their canonical names
 772          stored in them.  */
 773       while (*p)
 774         {
 775           if (*p == '-')
 776             dashes++;
 777           p++;
 778         }
 779
 780       if (dashes >= 13)
 781         {
 782           len = xfont_decode_coding_xlfd (p0, -1, name);
 783           fullname = Fdowncase (make_string (name, len));
 784         }
 785       XFree (p0);
 786     }
 787   x_uncatch_errors ();
 788   UNBLOCK_INPUT;
 789
 790   if (! xfont)
 791     {
 792       FONT_ADD_LOG ("  x:open failed", build_string (name), Qnil);
 793       return Qnil;
 794     }
 795
 796   font_object = font_make_object (VECSIZE (struct xfont_info),
 797                                   entity, pixel_size);
 798   ASET (font_object, FONT_TYPE_INDEX, Qx);
 799   if (STRINGP (fullname))
 800     {
 801       font_parse_xlfd (SSDATA (fullname), SBYTES (fullname), font_object);
 802       ASET (font_object, FONT_NAME_INDEX, fullname);
 803     }
 804   else
 805     {
 806       char buf[512];
 807
 808       len = xfont_decode_coding_xlfd (name, -1, buf);
 809       ASET (font_object, FONT_NAME_INDEX, make_string (buf, len));
 810     }
 811   ASET (font_object, FONT_FULLNAME_INDEX, fullname);
 812   ASET (font_object, FONT_FILE_INDEX, Qnil);
 813   ASET (font_object, FONT_FORMAT_INDEX, Qx);
 814   font = XFONT_OBJECT (font_object);
 815   ((struct xfont_info *) font)->xfont = xfont;
 816   ((struct xfont_info *) font)->display = FRAME_X_DISPLAY (f);
 817   font->pixel_size = pixel_size;
 818   font->driver = &xfont_driver;
 819   font->encoding_charset = encoding->id;
 820   font->repertory_charset = repertory ? repertory->id : -1;
 821   font->ascent = xfont->ascent;
 822   font->descent = xfont->descent;
 823   font->height = font->ascent + font->descent;
 824   font->min_width = xfont->min_bounds.width;
 825   font->max_width = xfont->max_bounds.width;
 826   if (xfont->min_bounds.width == xfont->max_bounds.width)
 827     {
 828       /* Fixed width font.  */
 829       font->average_width = font->space_width = xfont->min_bounds.width;
 830     }
 831   else
 832     {
 833       XCharStruct *pcm;
 834       XChar2b char2b;
 835       Lisp_Object val;
 836
 837       char2b.byte1 = 0x00, char2b.byte2 = 0x20;
 838       pcm = xfont_get_pcm (xfont, &char2b);
 839       if (pcm)
 840         font->space_width = pcm->width;
 841       else
 842         font->space_width = 0;
 843
 844       val = Ffont_get (font_object, QCavgwidth);
 845       if (INTEGERP (val))
 846         font->average_width = XINT (val) / 10;
 847       if (font->average_width < 0)
 848         font->average_width = - font->average_width;
 849       else
 850         {
 851           if (font->average_width == 0
 852               && encoding->ascii_compatible_p)
 853             {
 854               int width = font->space_width, n = pcm != NULL;
 855
 856               for (char2b.byte2 = 33; char2b.byte2 <= 126; char2b.byte2++)
 857                 if ((pcm = xfont_get_pcm (xfont, &char2b)) != NULL)
 858                   width += pcm->width, n++;
 859               if (n > 0)
 860                 font->average_width = width / n;
 861             }
 862           if (font->average_width == 0)
 863             /* No easy way other than this to get a reasonable
 864                average_width.  */
 865             font->average_width
 866               = (xfont->min_bounds.width + xfont->max_bounds.width) / 2;
 867         }
 868     }
 869
 870   BLOCK_INPUT;
 871   font->underline_thickness
 872     = (XGetFontProperty (xfont, XA_UNDERLINE_THICKNESS, &value)
 873        ? (long) value : 0);
 874   font->underline_position
 875     = (XGetFontProperty (xfont, XA_UNDERLINE_POSITION, &value)
 876        ? (long) value : -1);
 877   font->baseline_offset
 878     = (XGetFontProperty (xfont, dpyinfo->Xatom_MULE_BASELINE_OFFSET, &value)
 879        ? (long) value : 0);
 880   font->relative_compose
 881     = (XGetFontProperty (xfont, dpyinfo->Xatom_MULE_RELATIVE_COMPOSE, &value)
 882        ? (long) value : 0);
 883   font->default_ascent
 884     = (XGetFontProperty (xfont, dpyinfo->Xatom_MULE_DEFAULT_ASCENT, &value)
 885        ? (long) value : 0);
 886   UNBLOCK_INPUT;
 887
 888   if (NILP (fullname))
 889     fullname = AREF (font_object, FONT_NAME_INDEX);
 890   font->vertical_centering
 891     = (STRINGP (Vvertical_centering_font_regexp)
 892        && (fast_string_match_ignore_case
 893            (Vvertical_centering_font_regexp, fullname) >= 0));
 894
 895   return font_object;
 896 }
 897
 898 static void
 899 xfont_close (FRAME_PTR f, struct font *font)
 900 {
 901   BLOCK_INPUT;
 902   XFreeFont (FRAME_X_DISPLAY (f), ((struct xfont_info *) font)->xfont);
 903   UNBLOCK_INPUT;
 904 }
 905
 906 static int
 907 xfont_prepare_face (FRAME_PTR f, struct face *face)
 908 {
 909   BLOCK_INPUT;
 910   XSetFont (FRAME_X_DISPLAY (f), face->gc,
 911             ((struct xfont_info *) face->font)->xfont->fid);
 912   UNBLOCK_INPUT;
 913
 914   return 0;
 915 }
 916
 917 static int
 918 xfont_has_char (Lisp_Object font, int c)
 919 {
 920   Lisp_Object registry = AREF (font, FONT_REGISTRY_INDEX);
 921   struct charset *encoding;
 922   struct charset *repertory = NULL;
 923
 924   if (EQ (registry, Qiso10646_1))
 925     {
 926       encoding = CHARSET_FROM_ID (charset_unicode);
 927       /* We use a font of `ja' and `ko' adstyle only for a character
 928          in JISX0208 and KSC5601 charsets respectively.  */
 929       if (EQ (AREF (font, FONT_ADSTYLE_INDEX), Qja)
 930           && charset_jisx0208 >= 0)
 931         repertory = CHARSET_FROM_ID (charset_jisx0208);
 932       else if (EQ (AREF (font, FONT_ADSTYLE_INDEX), Qko)
 933                && charset_ksc5601 >= 0)
 934         repertory = CHARSET_FROM_ID (charset_ksc5601);
 935     }
 936   else if (font_registry_charsets (registry, &encoding, &repertory) < 0)
 937     /* Unknown REGISTRY, not usable.  */
 938     return 0;
 939   if (ASCII_CHAR_P (c) && encoding->ascii_compatible_p)
 940     return 1;
 941   if (! repertory)
 942     return -1;
 943   return (ENCODE_CHAR (repertory, c) != CHARSET_INVALID_CODE (repertory));
 944 }
 945
 946 static unsigned
 947 xfont_encode_char (struct font *font, int c)
 948 {
 949   XFontStruct *xfont = ((struct xfont_info *) font)->xfont;
 950   struct charset *charset;
 951   unsigned code;
 952   XChar2b char2b;
 953
 954   charset = CHARSET_FROM_ID (font->encoding_charset);
 955   code = ENCODE_CHAR (charset, c);
 956   if (code == CHARSET_INVALID_CODE (charset))
 957     return FONT_INVALID_CODE;
 958   if (font->repertory_charset >= 0)
 959     {
 960       charset = CHARSET_FROM_ID (font->repertory_charset);
 961       return (ENCODE_CHAR (charset, c) != CHARSET_INVALID_CODE (charset)
 962               ? code : FONT_INVALID_CODE);
 963     }
 964   char2b.byte1 = code >> 8;
 965   char2b.byte2 = code & 0xFF;
 966   return (xfont_get_pcm (xfont, &char2b) ? code : FONT_INVALID_CODE);
 967 }
 968
 969 static int
 970 xfont_text_extents (struct font *font, unsigned int *code, int nglyphs, struct font_metrics *metrics)
 971 {
 972   XFontStruct *xfont = ((struct xfont_info *) font)->xfont;
 973   int width = 0;
 974   int i, first;
 975
 976   if (metrics)
 977     memset (metrics, 0, sizeof (struct font_metrics));
 978   for (i = 0, first = 1; i < nglyphs; i++)
 979     {
 980       XChar2b char2b;
 981       static XCharStruct *pcm;
 982
 983       if (code[i] >= 0x10000)
 984         continue;
 985       char2b.byte1 = code[i] >> 8, char2b.byte2 = code[i] & 0xFF;
 986       pcm = xfont_get_pcm (xfont, &char2b);
 987       if (! pcm)
 988         continue;
 989       if (first)
 990         {
 991           if (metrics)
 992             {
 993               metrics->lbearing = pcm->lbearing;
 994               metrics->rbearing = pcm->rbearing;
 995               metrics->ascent = pcm->ascent;
 996               metrics->descent = pcm->descent;
 997             }
 998           first = 0;
 999         }
1000       else
1001         {
1002           if (metrics)
1003             {
1004               if (metrics->lbearing > width + pcm->lbearing)
1005                 metrics->lbearing = width + pcm->lbearing;
1006               if (metrics->rbearing < width + pcm->rbearing)
1007                 metrics->rbearing = width + pcm->rbearing;
1008               if (metrics->ascent < pcm->ascent)
1009                 metrics->ascent = pcm->ascent;
1010               if (metrics->descent < pcm->descent)
1011                 metrics->descent = pcm->descent;
1012             }
1013         }
1014       width += pcm->width;
1015     }
1016   if (metrics)
1017     metrics->width = width;
1018   return width;
1019 }
1020
1021 static int
1022 xfont_draw (struct glyph_string *s, int from, int to, int x, int y, int with_background)
1023 {
1024   XFontStruct *xfont = ((struct xfont_info *) s->font)->xfont;
1025   int len = to - from;
1026   GC gc = s->gc;
1027   int i;
1028
1029   if (s->gc != s->face->gc)
1030     {
1031       BLOCK_INPUT;
1032       XSetFont (s->display, gc, xfont->fid);
1033       UNBLOCK_INPUT;
1034     }
1035
1036   if (xfont->min_byte1 == 0 && xfont->max_byte1 == 0)
1037     {
1038       USE_SAFE_ALLOCA;
1039       char *str = SAFE_ALLOCA (len);
1040       for (i = 0; i < len ; i++)
1041         str[i] = XCHAR2B_BYTE2 (s->char2b + from + i);
1042       BLOCK_INPUT;
1043       if (with_background > 0)
1044         {
1045           if (s->padding_p)
1046             for (i = 0; i < len; i++)
1047               XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1048                                 gc, x + i, y, str + i, 1);
1049           else
1050             XDrawImageString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1051                               gc, x, y, str, len);
1052         }
1053       else
1054         {
1055           if (s->padding_p)
1056             for (i = 0; i < len; i++)
1057               XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1058                            gc, x + i, y, str + i, 1);
1059           else
1060             XDrawString (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1061                          gc, x, y, str, len);
1062         }
1063       UNBLOCK_INPUT;
1064       SAFE_FREE ();
1065       return s->nchars;
1066     }
1067
1068   BLOCK_INPUT;
1069   if (with_background > 0)
1070     {
1071       if (s->padding_p)
1072         for (i = 0; i < len; i++)
1073           XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1074                               gc, x + i, y, s->char2b + from + i, 1);
1075       else
1076         XDrawImageString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1077                             gc, x, y, s->char2b + from, len);
1078     }
1079   else
1080     {
1081       if (s->padding_p)
1082         for (i = 0; i < len; i++)
1083           XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1084                          gc, x + i, y, s->char2b + from + i, 1);
1085       else
1086         XDrawString16 (FRAME_X_DISPLAY (s->f), FRAME_X_WINDOW (s->f),
1087                        gc, x, y, s->char2b + from, len);
1088     }
1089   UNBLOCK_INPUT;
1090
1091   return len;
1092 }
1093
1094 static int
1095 xfont_check (FRAME_PTR f, struct font *font)
1096 {
1097   struct xfont_info *xfont = (struct xfont_info *) font;
1098
1099   return (FRAME_X_DISPLAY (f) == xfont->display ? 0 : -1);
1100 }
1101
1102 \f
1103 void
1104 syms_of_xfont (void)
1105 {
1106   staticpro (&xfont_scripts_cache);
1107   { /* Here we rely on the fact that syms_of_xfont (via syms_of_font)
1108        is called fairly late, when QCtest and Qequal are known to be set.  */
1109     Lisp_Object args[2];
1110     args[0] = QCtest;
1111     args[1] = Qequal;
1112     xfont_scripts_cache = Fmake_hash_table (2, args);
1113   }
1114   staticpro (&xfont_scratch_props);
1115   xfont_scratch_props = Fmake_vector (make_number (8), Qnil);
1116   xfont_driver.type = Qx;
1117   register_font_driver (&xfont_driver, NULL);
1118 }