src/objects-x.c

   1 /* X-specific Lisp objects.
   2    Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   3    Copyright (C) 1995 Board of Trustees, University of Illinois.
   4    Copyright (C) 1995 Tinker Systems.
   5    Copyright (C) 1995, 1996, 2000 Ben Wing.
   6    Copyright (C) 1995 Sun Microsystems, Inc.
   7
   8 This file is part of XEmacs.
   9
  10 XEmacs is free software; you can redistribute it and/or modify it
  11 under the terms of the GNU General Public License as published by the
  12 Free Software Foundation; either version 2, or (at your option) any
  13 later version.
  14
  15 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  16 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  17 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  18 for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with XEmacs; see the file COPYING.  If not, write to
  22 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 Boston, MA 02111-1307, USA.  */
  24
  25 /* Synched up with: Not in FSF. */
  26
  27 /* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */
  28
  29 /* This file Mule-ized by Ben Wing, 7-10-00. */
  30
  31 #include <config.h>
  32 #include "lisp.h"
  33
  34 #include "console-x.h"
  35 #include "objects-x.h"
  36
  37 #include "buffer.h"
  38 #include "device.h"
  39 #include "insdel.h"
  40
  41 int x_handle_non_fully_specified_fonts;
  42
  43 \f
  44 /************************************************************************/
  45 /*                          color instances                             */
  46 /************************************************************************/
  47
  48 /* Replacement for XAllocColor() that tries to return the nearest
  49    available color if the colormap is full.  Original was from FSFmacs,
  50    but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25
  51    Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous
  52    total failure which was due to a read/write colorcell being the nearest
  53    match - tries the next nearest...
  54
  55    Return value is 1 for normal success, 2 for nearest color success,
  56    3 for Non-deallocable success. */
  57 int
  58 allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
  59                         XColor *color_def)
  60 {
  61   int status;
  62
  63   if (visual->class == DirectColor || visual->class == TrueColor)
  64     {
  65       if (XAllocColor (display, colormap, color_def) != 0)
  66         {
  67           status = 1;
  68         }
  69       else
  70         {
  71           /* We're dealing with a TrueColor/DirectColor visual, so play games
  72              with the RGB values in the XColor struct. */
  73           /* #### JH: I'm not sure how a call to XAllocColor can fail in a
  74              TrueColor or DirectColor visual, so I will just reformat the
  75              request to match the requirements of the visual, and re-issue
  76              the request.  If this fails for anybody, I wanna know about it
  77              so I can come up with a better plan */
  78
  79           unsigned long rshift,gshift,bshift,rbits,gbits,bbits,junk;
  80           junk = visual->red_mask;
  81           rshift = 0;
  82           while ((junk & 0x1) == 0) {
  83             junk = junk >> 1;
  84             rshift ++;
  85           }
  86           rbits = 0;
  87           while (junk != 0) {
  88             junk = junk >> 1;
  89             rbits++;
  90           }
  91           junk = visual->green_mask;
  92           gshift = 0;
  93           while ((junk & 0x1) == 0) {
  94             junk = junk >> 1;
  95             gshift ++;
  96           }
  97           gbits = 0;
  98           while (junk != 0) {
  99             junk = junk >> 1;
 100             gbits++;
 101           }
 102           junk = visual->blue_mask;
 103           bshift = 0;
 104           while ((junk & 0x1) == 0) {
 105             junk = junk >> 1;
 106             bshift ++;
 107           }
 108           bbits = 0;
 109           while (junk != 0) {
 110             junk = junk >> 1;
 111             bbits++;
 112           }
 113
 114           color_def->red = color_def->red >> (16 - rbits);
 115           color_def->green = color_def->green >> (16 - gbits);
 116           color_def->blue = color_def->blue >> (16 - bbits);
 117           if (XAllocColor (display, colormap, color_def) != 0)
 118             status = 1;
 119           else
 120             {
 121               int rd, gr, bl;
 122               /* #### JH: I'm punting here, knowing that doing this will at
 123                  least draw the color correctly.  However, unless we convert
 124                  all of the functions that allocate colors (graphics
 125                  libraries, etc) to use this function doing this is very
 126                  likely to cause problems later... */
 127
 128               if (rbits > 8)
 129                 rd = color_def->red << (rbits - 8);
 130               else
 131                 rd = color_def->red >> (8 - rbits);
 132               if (gbits > 8)
 133                 gr = color_def->green << (gbits - 8);
 134               else
 135                 gr = color_def->green >> (8 - gbits);
 136               if (bbits > 8)
 137                 bl = color_def->blue << (bbits - 8);
 138               else
 139                 bl = color_def->blue >> (8 - bbits);
 140               color_def->pixel = (rd << rshift) | (gr << gshift) | (bl <<
 141                                                                     bshift);
 142               status = 3;
 143             }
 144         }
 145     }
 146   else
 147     {
 148       XColor *cells = NULL;
 149       /* JH: I can't believe there's no way to go backwards from a
 150          colormap ID and get its visual and number of entries, but X
 151          apparently isn't built that way... */
 152       int no_cells = visual->map_entries;
 153       status = 0;
 154
 155       if (XAllocColor (display, colormap, color_def) != 0)
 156         status = 1;
 157       else while( status != 2 )
 158         {
 159           /* If we got to this point, the colormap is full, so we're
 160              going to try and get the next closest color.  The algorithm used
 161              is a least-squares matching, which is what X uses for closest
 162              color matching with StaticColor visuals. */
 163           int nearest;
 164           long nearest_delta, trial_delta;
 165           int x;
 166
 167           if( cells == NULL )
 168             {
 169               cells = alloca_array (XColor, no_cells);
 170               for (x = 0; x < no_cells; x++)
 171                 cells[x].pixel = x;
 172
 173               /* read the current colormap */
 174               XQueryColors (display, colormap, cells, no_cells);
 175             }
 176
 177           nearest = 0;
 178           /* I'm assuming CSE so I'm not going to condense this. */
 179           nearest_delta = ((((color_def->red >> 8) - (cells[0].red >> 8))
 180                             * ((color_def->red >> 8) - (cells[0].red >> 8)))
 181                            +
 182                            (((color_def->green >> 8) - (cells[0].green >> 8))
 183                             * ((color_def->green >> 8) - (cells[0].green >>
 184                                                           8)))
 185                            +
 186                            (((color_def->blue >> 8) - (cells[0].blue >> 8))
 187                             * ((color_def->blue >> 8) - (cells[0].blue >>
 188                                                          8))));
 189           for (x = 1; x < no_cells; x++)
 190             {
 191               trial_delta = ((((color_def->red >> 8) - (cells[x].red >> 8))
 192                               * ((color_def->red >> 8) - (cells[x].red >> 8)))
 193                              +
 194                              (((color_def->green >> 8) - (cells[x].green >> 8))
 195                               * ((color_def->green >> 8) - (cells[x].green >>
 196                                                             8)))
 197                              +
 198                              (((color_def->blue >> 8) - (cells[x].blue >> 8))
 199                               * ((color_def->blue >> 8) - (cells[x].blue >>
 200                                                            8))));
 201
 202               /* less? Ignore cells marked as previously failing */
 203               if( (trial_delta < nearest_delta) &&
 204                   (cells[x].pixel != ULONG_MAX) )
 205                 {
 206                   nearest = x;
 207                   nearest_delta = trial_delta;
 208                 }
 209             }
 210           color_def->red = cells[nearest].red;
 211           color_def->green = cells[nearest].green;
 212           color_def->blue = cells[nearest].blue;
 213           if (XAllocColor (display, colormap, color_def) != 0)
 214             status = 2;
 215           else
 216             /* LSK: Either the colour map has changed since
 217              * we read it, or the colour is allocated
 218              * read/write... Mark this cmap entry so it's
 219              * ignored in the next iteration.
 220              */
 221             cells[nearest].pixel = ULONG_MAX;
 222         }
 223     }
 224   return status;
 225 }
 226
 227 static int
 228 x_parse_nearest_color (struct device *d, XColor *color, Lisp_Object name,
 229                        Error_behavior errb)
 230 {
 231   Display *dpy   = DEVICE_X_DISPLAY  (d);
 232   Colormap cmap  = DEVICE_X_COLORMAP (d);
 233   Visual *visual = DEVICE_X_VISUAL   (d);
 234   int result;
 235
 236   xzero (*color);
 237   {
 238     const Extbyte *extname;
 239
 240     LISP_STRING_TO_EXTERNAL (name, extname, Qx_color_name_encoding);
 241     result = XParseColor (dpy, cmap, extname, color);
 242   }
 243   if (!result)
 244     {
 245       maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb);
 246       return 0;
 247     }
 248   result = allocate_nearest_color (dpy, cmap, visual, color);
 249   if (!result)
 250     {
 251       maybe_signal_simple_error ("Couldn't allocate color", name, Qcolor,
 252                                  errb);
 253       return 0;
 254     }
 255
 256   return result;
 257 }
 258
 259 static int
 260 x_initialize_color_instance (Lisp_Color_Instance *c, Lisp_Object name,
 261                              Lisp_Object device, Error_behavior errb)
 262 {
 263   XColor color;
 264   int result;
 265
 266   result = x_parse_nearest_color (XDEVICE (device), &color, name, errb);
 267
 268   if (!result)
 269     return 0;
 270
 271   /* Don't allocate the data until we're sure that we will succeed,
 272      or the finalize method may get fucked. */
 273   c->data = xnew (struct x_color_instance_data);
 274   if (result == 3)
 275     COLOR_INSTANCE_X_DEALLOC (c) = 0;
 276   else
 277     COLOR_INSTANCE_X_DEALLOC (c) = 1;
 278   COLOR_INSTANCE_X_COLOR (c) = color;
 279   return 1;
 280 }
 281
 282 static void
 283 x_print_color_instance (Lisp_Color_Instance *c,
 284                         Lisp_Object printcharfun,
 285                         int escapeflag)
 286 {
 287   char buf[100];
 288   XColor color = COLOR_INSTANCE_X_COLOR (c);
 289   sprintf (buf, " %ld=(%X,%X,%X)",
 290            color.pixel, color.red, color.green, color.blue);
 291   write_c_string (buf, printcharfun);
 292 }
 293
 294 static void
 295 x_finalize_color_instance (Lisp_Color_Instance *c)
 296 {
 297   if (c->data)
 298     {
 299       if (DEVICE_LIVE_P (XDEVICE (c->device)))
 300         {
 301           if (COLOR_INSTANCE_X_DEALLOC (c))
 302             {
 303               XFreeColors (DEVICE_X_DISPLAY (XDEVICE (c->device)),
 304                            DEVICE_X_COLORMAP (XDEVICE (c->device)),
 305                            &COLOR_INSTANCE_X_COLOR (c).pixel, 1, 0);
 306             }
 307         }
 308       xfree (c->data);
 309       c->data = 0;
 310     }
 311 }
 312
 313 /* Color instances are equal if they resolve to the same color on the
 314    screen (have the same RGB values).  I imagine that
 315    "same RGB values" == "same cell in the colormap."  Arguably we should
 316    be comparing their names or pixel values instead. */
 317
 318 static int
 319 x_color_instance_equal (Lisp_Color_Instance *c1,
 320                         Lisp_Color_Instance *c2,
 321                         int depth)
 322 {
 323   XColor color1 = COLOR_INSTANCE_X_COLOR (c1);
 324   XColor color2 = COLOR_INSTANCE_X_COLOR (c2);
 325   return ((color1.red == color2.red) &&
 326           (color1.green == color2.green) &&
 327           (color1.blue == color2.blue));
 328 }
 329
 330 static unsigned long
 331 x_color_instance_hash (Lisp_Color_Instance *c, int depth)
 332 {
 333   XColor color = COLOR_INSTANCE_X_COLOR (c);
 334   return HASH3 (color.red, color.green, color.blue);
 335 }
 336
 337 static Lisp_Object
 338 x_color_instance_rgb_components (Lisp_Color_Instance *c)
 339 {
 340   XColor color = COLOR_INSTANCE_X_COLOR (c);
 341   return (list3 (make_int (color.red),
 342                  make_int (color.green),
 343                  make_int (color.blue)));
 344 }
 345
 346 static int
 347 x_valid_color_name_p (struct device *d, Lisp_Object color)
 348 {
 349   XColor c;
 350   Display *dpy = DEVICE_X_DISPLAY (d);
 351   Colormap cmap = DEVICE_X_COLORMAP (d);
 352   const Extbyte *extname;
 353
 354   LISP_STRING_TO_EXTERNAL (color, extname, Qx_color_name_encoding);
 355
 356   return XParseColor (dpy, cmap, extname, &c);
 357 }
 358
 359 \f
 360 /************************************************************************/
 361 /*                           font instances                             */
 362 /************************************************************************/
 363
 364 static int
 365 x_initialize_font_instance (Lisp_Font_Instance *f, Lisp_Object name,
 366                             Lisp_Object device, Error_behavior errb)
 367 {
 368   Display *dpy = DEVICE_X_DISPLAY (XDEVICE (device));
 369   XFontStruct *xf;
 370   const Extbyte *extname;
 371
 372   LISP_STRING_TO_EXTERNAL (f->name, extname, Qx_font_name_encoding);
 373   xf = XLoadQueryFont (dpy, extname);
 374
 375   if (!xf)
 376     {
 377       maybe_signal_simple_error ("Couldn't load font", f->name,
 378                                  Qfont, errb);
 379       return 0;
 380     }
 381
 382   if (!xf->max_bounds.width)
 383     {
 384       /* yes, this has been known to happen. */
 385       XFreeFont (dpy, xf);
 386       maybe_signal_simple_error ("X font is too small", f->name,
 387                                  Qfont, errb);
 388       return 0;
 389     }
 390
 391   /* Don't allocate the data until we're sure that we will succeed,
 392      or the finalize method may get fucked. */
 393   f->data = xnew (struct x_font_instance_data);
 394   FONT_INSTANCE_X_TRUENAME (f) = Qnil;
 395   FONT_INSTANCE_X_FONT (f) = xf;
 396   f->ascent = xf->ascent;
 397   f->descent = xf->descent;
 398   f->height = xf->ascent + xf->descent;
 399   {
 400     /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */
 401     unsigned int def_char = 'n'; /*xf->default_char;*/
 402     unsigned int byte1, byte2;
 403
 404   once_more:
 405     byte1 = def_char >> 8;
 406     byte2 = def_char & 0xFF;
 407
 408     if (xf->per_char)
 409       {
 410         /* Old versions of the R5 font server have garbage (>63k) as
 411            def_char. 'n' might not be a valid character. */
 412         if (byte1 < xf->min_byte1         ||
 413             byte1 > xf->max_byte1         ||
 414             byte2 < xf->min_char_or_byte2 ||
 415             byte2 > xf->max_char_or_byte2)
 416           f->width = 0;
 417         else
 418           f->width = xf->per_char[(byte1 - xf->min_byte1) *
 419                                   (xf->max_char_or_byte2 -
 420                                    xf->min_char_or_byte2 + 1) +
 421                                   (byte2 - xf->min_char_or_byte2)].width;
 422       }
 423     else
 424       f->width = xf->max_bounds.width;
 425
 426     /* Some fonts have a default char whose width is 0.  This is no good.
 427        If that's the case, first try 'n' as the default char, and if n has
 428        0 width too (unlikely) then just use the max width. */
 429     if (f->width == 0)
 430       {
 431         if (def_char == xf->default_char)
 432           f->width = xf->max_bounds.width;
 433         else
 434           {
 435             def_char = xf->default_char;
 436             goto once_more;
 437           }
 438       }
 439   }
 440   /* If all characters don't exist then there could potentially be
 441      0-width characters lurking out there.  Not setting this flag
 442      trips an optimization that would make them appear to have width
 443      to redisplay.  This is bad.  So we set it if not all characters
 444      have the same width or if not all characters are defined.
 445      */
 446   /* #### This sucks.  There is a measurable performance increase
 447      when using proportional width fonts if this flag is not set.
 448      Unfortunately so many of the fucking X fonts are not fully
 449      defined that we could almost just get rid of this damn flag and
 450      make it an assertion. */
 451   f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width ||
 452                        (x_handle_non_fully_specified_fonts &&
 453                         !xf->all_chars_exist));
 454
 455   return 1;
 456 }
 457
 458 static void
 459 x_mark_font_instance (Lisp_Font_Instance *f)
 460 {
 461   mark_object (FONT_INSTANCE_X_TRUENAME (f));
 462 }
 463
 464 static void
 465 x_print_font_instance (Lisp_Font_Instance *f,
 466                        Lisp_Object printcharfun,
 467                        int escapeflag)
 468 {
 469   char buf[200];
 470   sprintf (buf, " 0x%lx", (unsigned long) FONT_INSTANCE_X_FONT (f)->fid);
 471   write_c_string (buf, printcharfun);
 472 }
 473
 474 static void
 475 x_finalize_font_instance (Lisp_Font_Instance *f)
 476 {
 477
 478   if (f->data)
 479     {
 480       if (DEVICE_LIVE_P (XDEVICE (f->device)))
 481         {
 482           Display *dpy = DEVICE_X_DISPLAY (XDEVICE (f->device));
 483
 484           XFreeFont (dpy, FONT_INSTANCE_X_FONT (f));
 485         }
 486       xfree (f->data);
 487       f->data = 0;
 488     }
 489 }
 490
 491 /* Determining the truename of a font is hard.  (Big surprise.)
 492
 493    By "truename" we mean an XLFD-form name which contains no wildcards, yet
 494    which resolves to *exactly* the same font as the one which we already have
 495    the (probably wildcarded) name and `XFontStruct' of.
 496
 497    One might think that the first font returned by XListFonts would be the one
 498    that XOpenFont would pick.  Apparently this is the case on some servers,
 499    but not on others.  It would seem not to be specified.
 500
 501    The MIT R5 server sometimes appears to be picking the lexicographically
 502    smallest font which matches the name (thus picking "adobe" fonts before
 503    "bitstream" fonts even if the bitstream fonts are earlier in the path, and
 504    also picking 100dpi adobe fonts over 75dpi adobe fonts even though the
 505    75dpi are in the path earlier) but sometimes appears to be doing something
 506    else entirely (for example, removing the bitstream fonts from the path will
 507    cause the 75dpi adobe fonts to be used instead of the 100dpi, even though
 508    their relative positions in the path (and their names!) have not changed).
 509
 510    The documentation for XSetFontPath() seems to indicate that the order of
 511    entries in the font path means something, but it's pretty noncommittal about
 512    it, and the spirit of the law is apparently not being obeyed...
 513
 514    All the fonts I've seen have a property named `FONT' which contains the
 515    truename of the font.  However, there are two problems with using this: the
 516    first is that the X Protocol Document is quite explicit that all properties
 517    are optional, so we can't depend on it being there.  The second is that
 518    it's conceivable that this alleged truename isn't actually accessible as a
 519    font, due to some difference of opinion between the font designers and
 520    whoever installed the font on the system.
 521
 522    So, our first attempt is to look for a FONT property, and then verify that
 523    the name there is a valid name by running XListFonts on it.  There's still
 524    the potential that this could be true but we could still be being lied to,
 525    but that seems pretty remote.
 526
 527      Late breaking news: I've gotten reports that SunOS 4.1.3U1
 528      with OpenWound 3.0 has a font whose truename is really
 529      "-Adobe-Courier-Medium-R-Normal--12-120-75-75-M-70-ISO8859-1"
 530      but whose FONT property contains "Courier".
 531
 532      So we disbelieve the FONT property unless it begins with a dash and
 533      is more than 30 characters long.  X Windows: The defacto substandard.
 534      X Windows: Complex nonsolutions to simple nonproblems.  X Windows:
 535      Live the nightmare.
 536
 537    If the FONT property doesn't exist, then we try and construct an XLFD name
 538    out of the other font properties (FOUNDRY, FAMILY_NAME, WEIGHT_NAME, etc).
 539    This is necessary at least for some versions of OpenWound.  But who knows
 540    what the future will bring.
 541
 542    If that doesn't work, then we use XListFonts and either take the first font
 543    (which I think is the most sensible thing) or we find the lexicographically
 544    least, depending on whether the preprocessor constant `XOPENFONT_SORTS' is
 545    defined.  This sucks because the two behaviors are a property of the server
 546    being used, not the architecture on which emacs has been compiled.  Also,
 547    as I described above, sorting isn't ALWAYS what the server does.  Really it
 548    does something seemingly random.  There is no reliable way to win if the
 549    FONT property isn't present.
 550
 551    Another possibility which I haven't bothered to implement would be to map
 552    over all of the matching fonts and find the first one that has the same
 553    character metrics as the font we already have loaded.  Even if this didn't
 554    return exactly the same font, it would at least return one whose characters
 555    were the same sizes, which would probably be good enough.
 556
 557    More late-breaking news: on RS/6000 AIX 3.2.4, the expression
 558         XLoadQueryFont (dpy, "-*-Fixed-Medium-R-*-*-*-130-75-75-*-*-ISO8859-1")
 559    actually returns the font
 560         -Misc-Fixed-Medium-R-Normal--13-120-75-75-C-80-ISO8859-1
 561    which is crazy, because that font doesn't even match that pattern!  It is
 562    also not included in the output produced by `xlsfonts' with that pattern.
 563
 564    So this is yet another example of XListFonts() and XOpenFont() using
 565    completely different algorithms.  This, however, is a goofier example of
 566    this bug, because in this case, it's not just the search order that is
 567    different -- the sets don't even intersect.
 568
 569    If anyone has any better ideas how to do this, or any insights on what it is
 570    that the various servers are actually doing, please let me know!  -- jwz. */
 571
 572 static int
 573 valid_x_font_name_p (Display *dpy, Extbyte *name)
 574 {
 575   /* Maybe this should be implemented by calling XLoadFont and trapping
 576      the error.  That would be a lot of work, and wasteful as hell, but
 577      might be more correct.
 578    */
 579   int nnames = 0;
 580   Extbyte **names = 0;
 581   if (! name)
 582     return 0;
 583   names = XListFonts (dpy, name, 1, &nnames);
 584   if (names)
 585     XFreeFontNames (names);
 586   return (nnames != 0);
 587 }
 588
 589 static Extbyte *
 590 truename_via_FONT_prop (Display *dpy, XFontStruct *font)
 591 {
 592   unsigned long value = 0;
 593   Extbyte *result = 0;
 594   if (XGetFontProperty (font, XA_FONT, &value))
 595     result = XGetAtomName (dpy, value);
 596   /* result is now 0, or the string value of the FONT property. */
 597   if (result)
 598     {
 599       /* Verify that result is an XLFD name (roughly...) */
 600       if (result [0] != '-' || strlen (result) < (unsigned int) 30)
 601         {
 602           XFree (result);
 603           result = 0;
 604         }
 605     }
 606   return result;        /* this must be freed by caller if non-0 */
 607 }
 608
 609 static Extbyte *
 610 truename_via_random_props (Display *dpy, XFontStruct *font)
 611 {
 612   struct device *d = get_device_from_display (dpy);
 613   unsigned long value = 0;
 614   Extbyte *foundry, *family, *weight, *slant, *setwidth, *add_style;
 615   unsigned long pixel, point, res_x, res_y;
 616   Extbyte *spacing;
 617   unsigned long avg_width;
 618   Extbyte *registry, *encoding;
 619   Extbyte composed_name [2048];
 620   int ok = 0;
 621   Extbyte *result;
 622
 623 #define get_string(atom,var)                            \
 624   if (XGetFontProperty (font, (atom), &value))          \
 625     var = XGetAtomName (dpy, value);                    \
 626   else  {                                               \
 627     var = 0;                                            \
 628     goto FAIL; }
 629 #define get_number(atom,var)                            \
 630   if (!XGetFontProperty (font, (atom), &var) ||         \
 631       var > 999)                                        \
 632     goto FAIL;
 633
 634   foundry = family = weight = slant = setwidth = 0;
 635   add_style = spacing = registry = encoding = 0;
 636
 637   get_string (DEVICE_XATOM_FOUNDRY (d), foundry);
 638   get_string (DEVICE_XATOM_FAMILY_NAME (d), family);
 639   get_string (DEVICE_XATOM_WEIGHT_NAME (d), weight);
 640   get_string (DEVICE_XATOM_SLANT (d), slant);
 641   get_string (DEVICE_XATOM_SETWIDTH_NAME (d), setwidth);
 642   get_string (DEVICE_XATOM_ADD_STYLE_NAME (d), add_style);
 643   get_number (DEVICE_XATOM_PIXEL_SIZE (d), pixel);
 644   get_number (DEVICE_XATOM_POINT_SIZE (d), point);
 645   get_number (DEVICE_XATOM_RESOLUTION_X (d), res_x);
 646   get_number (DEVICE_XATOM_RESOLUTION_Y (d), res_y);
 647   get_string (DEVICE_XATOM_SPACING (d), spacing);
 648   get_number (DEVICE_XATOM_AVERAGE_WIDTH (d), avg_width);
 649   get_string (DEVICE_XATOM_CHARSET_REGISTRY (d), registry);
 650   get_string (DEVICE_XATOM_CHARSET_ENCODING (d), encoding);
 651 #undef get_number
 652 #undef get_string
 653
 654   sprintf (composed_name,
 655            "-%s-%s-%s-%s-%s-%s-%ld-%ld-%ld-%ld-%s-%ld-%s-%s",
 656            foundry, family, weight, slant, setwidth, add_style, pixel,
 657            point, res_x, res_y, spacing, avg_width, registry, encoding);
 658   ok = 1;
 659
 660  FAIL:
 661   if (ok)
 662     {
 663       int L = strlen (composed_name) + 1;
 664       result = (Extbyte *) xmalloc (L);
 665       strncpy (result, composed_name, L);
 666     }
 667   else
 668     result = 0;
 669
 670   if (foundry) XFree (foundry);
 671   if (family) XFree (family);
 672   if (weight) XFree (weight);
 673   if (slant) XFree (slant);
 674   if (setwidth) XFree (setwidth);
 675   if (add_style) XFree (add_style);
 676   if (spacing) XFree (spacing);
 677   if (registry) XFree (registry);
 678   if (encoding) XFree (encoding);
 679
 680   return result;
 681 }
 682
 683 /* Unbounded, for sufficiently small values of infinity... */
 684 #define MAX_FONT_COUNT INT_MAX
 685
 686 static Extbyte *
 687 truename_via_XListFonts (Display *dpy, Extbyte *font_name)
 688 {
 689   Extbyte *result = 0;
 690   Extbyte **names;
 691   int count = 0;
 692
 693 #ifndef XOPENFONT_SORTS
 694   /* In a sensible world, the first font returned by XListFonts()
 695      would be the font that XOpenFont() would use.  */
 696   names = XListFonts (dpy, font_name, 1, &count);
 697   if (count) result = names [0];
 698 #else
 699   /* But the world I live in is much more perverse. */
 700   names = XListFonts (dpy, font_name, MAX_FONT_COUNT, &count);
 701   while (count--)
 702     /* !!#### Not Mule-friendly */
 703     /* If names[count] is lexicographically less than result, use it.
 704        (#### Should we be comparing case-insensitively?) */
 705     if (result == 0 || (strcmp (result, names [count]) < 0))
 706       result = names [count];
 707 #endif
 708
 709   if (result)
 710     result = xstrdup (result);
 711   if (names)
 712     XFreeFontNames (names);
 713
 714   return result;        /* this must be freed by caller if non-0 */
 715 }
 716
 717 static Lisp_Object
 718 x_font_truename (Display *dpy, Extbyte *name, XFontStruct *font)
 719 {
 720   Extbyte *truename_FONT = 0;
 721   Extbyte *truename_random = 0;
 722   Extbyte *truename = 0;
 723
 724   /* The search order is:
 725      - if FONT property exists, and is a valid name, return it.
 726      - if the other props exist, and add up to a valid name, return it.
 727      - if we find a matching name with XListFonts, return it.
 728      - if FONT property exists, return it regardless.
 729      - if other props exist, return the resultant name regardless.
 730      - else return 0.
 731    */
 732
 733   truename = truename_FONT = truename_via_FONT_prop (dpy, font);
 734   if (truename && !valid_x_font_name_p (dpy, truename))
 735     truename = 0;
 736   if (!truename)
 737     truename = truename_random = truename_via_random_props (dpy, font);
 738   if (truename && !valid_x_font_name_p (dpy, truename))
 739     truename = 0;
 740   if (!truename && name)
 741     truename = truename_via_XListFonts (dpy, name);
 742
 743   if (!truename)
 744     {
 745       /* Gag - we weren't able to find a seemingly-valid truename.
 746          Well, maybe we're on one of those braindead systems where
 747          XListFonts() and XLoadFont() are in violent disagreement.
 748          If we were able to compute a truename, try using that even
 749          if evidence suggests that it's not a valid name - because
 750          maybe it is, really, and that's better than nothing.
 751          X Windows: You'll envy the dead.
 752        */
 753       if (truename_FONT)
 754         truename = truename_FONT;
 755       else if (truename_random)
 756         truename = truename_random;
 757     }
 758
 759   /* One or both of these are not being used - free them. */
 760   if (truename_FONT && truename_FONT != truename)
 761     XFree (truename_FONT);
 762   if (truename_random && truename_random != truename)
 763     XFree (truename_random);
 764
 765   if (truename)
 766     {
 767       Lisp_Object result = build_ext_string (truename, Qx_font_name_encoding);
 768       XFree (truename);
 769       return result;
 770     }
 771   else
 772     return Qnil;
 773 }
 774
 775 static Lisp_Object
 776 x_font_instance_truename (Lisp_Font_Instance *f, Error_behavior errb)
 777 {
 778   struct device *d = XDEVICE (f->device);
 779
 780   if (NILP (FONT_INSTANCE_X_TRUENAME (f)))
 781     {
 782       Display *dpy = DEVICE_X_DISPLAY (d);
 783       {
 784         Extbyte *nameext;
 785
 786         LISP_STRING_TO_EXTERNAL (f->name, nameext, Qx_font_name_encoding);
 787         FONT_INSTANCE_X_TRUENAME (f) =
 788           x_font_truename (dpy, nameext, FONT_INSTANCE_X_FONT (f));
 789       }
 790       if (NILP (FONT_INSTANCE_X_TRUENAME (f)))
 791         {
 792           Lisp_Object font_instance;
 793           XSETFONT_INSTANCE (font_instance, f);
 794
 795           maybe_signal_simple_error ("Couldn't determine font truename",
 796                                      font_instance, Qfont, errb);
 797           /* Ok, just this once, return the font name as the truename.
 798              (This is only used by Fequal() right now.) */
 799           return f->name;
 800         }
 801     }
 802   return FONT_INSTANCE_X_TRUENAME (f);
 803 }
 804
 805 static Lisp_Object
 806 x_font_instance_properties (Lisp_Font_Instance *f)
 807 {
 808   struct device *d = XDEVICE (f->device);
 809   int i;
 810   Lisp_Object result = Qnil;
 811   Display *dpy = DEVICE_X_DISPLAY (d);
 812   XFontProp *props = FONT_INSTANCE_X_FONT (f)->properties;
 813
 814   for (i = FONT_INSTANCE_X_FONT (f)->n_properties - 1; i >= 0; i--)
 815     {
 816       Lisp_Object name, value;
 817       Atom atom = props [i].name;
 818       Bufbyte *name_str = 0;
 819       size_t name_len;
 820       Extbyte *namestrext = XGetAtomName (dpy, atom);
 821
 822       if (namestrext)
 823         TO_INTERNAL_FORMAT (C_STRING, namestrext,
 824                             ALLOCA, (name_str, name_len),
 825                             Qx_atom_name_encoding);
 826
 827       name = (name_str ? intern ((char *) name_str) : Qnil);
 828       if (name_str &&
 829           (atom == XA_FONT ||
 830            atom == DEVICE_XATOM_FOUNDRY (d) ||
 831            atom == DEVICE_XATOM_FAMILY_NAME (d) ||
 832            atom == DEVICE_XATOM_WEIGHT_NAME (d) ||
 833            atom == DEVICE_XATOM_SLANT (d) ||
 834            atom == DEVICE_XATOM_SETWIDTH_NAME (d) ||
 835            atom == DEVICE_XATOM_ADD_STYLE_NAME (d) ||
 836            atom == DEVICE_XATOM_SPACING (d) ||
 837            atom == DEVICE_XATOM_CHARSET_REGISTRY (d) ||
 838            atom == DEVICE_XATOM_CHARSET_ENCODING (d) ||
 839            !bufbyte_strcmp (name_str, "CHARSET_COLLECTIONS") ||
 840            !bufbyte_strcmp (name_str, "FONTNAME_REGISTRY") ||
 841            !bufbyte_strcmp (name_str, "CLASSIFICATION") ||
 842            !bufbyte_strcmp (name_str, "COPYRIGHT") ||
 843            !bufbyte_strcmp (name_str, "DEVICE_FONT_NAME") ||
 844            !bufbyte_strcmp (name_str, "FULL_NAME") ||
 845            !bufbyte_strcmp (name_str, "MONOSPACED") ||
 846            !bufbyte_strcmp (name_str, "QUALITY") ||
 847            !bufbyte_strcmp (name_str, "RELATIVE_SET") ||
 848            !bufbyte_strcmp (name_str, "RELATIVE_WEIGHT") ||
 849            !bufbyte_strcmp (name_str, "STYLE")))
 850         {
 851           Extbyte *val_str = XGetAtomName (dpy, props [i].card32);
 852
 853           value = (val_str ? build_ext_string (val_str, Qx_atom_name_encoding)
 854                    : Qnil);
 855         }
 856       else
 857         value = make_int (props [i].card32);
 858       if (namestrext) XFree (namestrext);
 859       result = Fcons (Fcons (name, value), result);
 860     }
 861   return result;
 862 }
 863
 864 static Lisp_Object
 865 x_list_fonts (Lisp_Object pattern, Lisp_Object device)
 866 {
 867   Extbyte **names;
 868   int count = 0;
 869   Lisp_Object result = Qnil;
 870   const Extbyte *patternext;
 871
 872   LISP_STRING_TO_EXTERNAL (pattern, patternext, Qx_font_name_encoding);
 873
 874   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
 875                       patternext, MAX_FONT_COUNT, &count);
 876   while (count--)
 877     result = Fcons (build_ext_string (names[count], Qx_font_name_encoding),
 878                     result);
 879   if (names)
 880     XFreeFontNames (names);
 881   return result;
 882 }
 883
 884 #ifdef MULE
 885
 886 static int
 887 x_font_spec_matches_charset (struct device *d, Lisp_Object charset,
 888                              const Bufbyte *nonreloc, Lisp_Object reloc,
 889                              Bytecount offset, Bytecount length)
 890 {
 891   if (UNBOUNDP (charset))
 892     return 1;
 893   /* Hack! Short font names don't have the registry in them,
 894      so we just assume the user knows what they're doing in the
 895      case of ASCII.  For other charsets, you gotta give the
 896      long form; sorry buster.
 897      */
 898   if (EQ (charset, Vcharset_ascii))
 899     {
 900       const Bufbyte *the_nonreloc = nonreloc;
 901       int i;
 902       Bytecount the_length = length;
 903
 904       if (!the_nonreloc)
 905         the_nonreloc = XSTRING_DATA (reloc);
 906       fixup_internal_substring (nonreloc, reloc, offset, &the_length);
 907       the_nonreloc += offset;
 908       if (!memchr (the_nonreloc, '*', the_length))
 909         {
 910           for (i = 0;; i++)
 911             {
 912               const Bufbyte *new_nonreloc = (const Bufbyte *)
 913                 memchr (the_nonreloc, '-', the_length);
 914               if (!new_nonreloc)
 915                 break;
 916               new_nonreloc++;
 917               the_length -= new_nonreloc - the_nonreloc;
 918               the_nonreloc = new_nonreloc;
 919             }
 920
 921           /* If it has less than 5 dashes, it's a short font.
 922              Of course, long fonts always have 14 dashes or so, but short
 923              fonts never have more than 1 or 2 dashes, so this is some
 924              sort of reasonable heuristic. */
 925           if (i < 5)
 926             return 1;
 927         }
 928     }
 929
 930   return (fast_string_match (XCHARSET_REGISTRY (charset),
 931                              nonreloc, reloc, offset, length, 1,
 932                              ERROR_ME, 0) >= 0);
 933 }
 934
 935 /* find a font spec that matches font spec FONT and also matches
 936    (the registry of) CHARSET. */
 937 static Lisp_Object
 938 x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
 939 {
 940   Extbyte **names;
 941   int count = 0;
 942   Lisp_Object result = Qnil;
 943   const Extbyte *patternext;
 944   int i;
 945
 946   LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding);
 947
 948   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
 949                       patternext, MAX_FONT_COUNT, &count);
 950   /* #### This code seems awfully bogus -- mrb */
 951   for (i = 0; i < count; i ++)
 952     {
 953       const Bufbyte *intname;
 954       Bytecount intlen;
 955
 956       TO_INTERNAL_FORMAT (C_STRING, names[i],
 957                           ALLOCA, (intname, intlen),
 958                           Qx_font_name_encoding);
 959       if (x_font_spec_matches_charset (XDEVICE (device), charset,
 960                                        intname, Qnil, 0, -1))
 961         {
 962           result = make_string (intname, intlen);
 963           break;
 964         }
 965     }
 966
 967   if (names)
 968     XFreeFontNames (names);
 969
 970   /* Check for a short font name. */
 971   if (NILP (result)
 972       && x_font_spec_matches_charset (XDEVICE (device), charset, 0,
 973                                       font, 0, -1))
 974     return font;
 975
 976   return result;
 977 }
 978
 979 #endif /* MULE */
 980
 981 \f
 982 /************************************************************************/
 983 /*                            initialization                            */
 984 /************************************************************************/
 985
 986 void
 987 syms_of_objects_x (void)
 988 {
 989 }
 990
 991 void
 992 console_type_create_objects_x (void)
 993 {
 994   /* object methods */
 995
 996   CONSOLE_HAS_METHOD (x, initialize_color_instance);
 997   CONSOLE_HAS_METHOD (x, print_color_instance);
 998   CONSOLE_HAS_METHOD (x, finalize_color_instance);
 999   CONSOLE_HAS_METHOD (x, color_instance_equal);
1000   CONSOLE_HAS_METHOD (x, color_instance_hash);
1001   CONSOLE_HAS_METHOD (x, color_instance_rgb_components);
1002   CONSOLE_HAS_METHOD (x, valid_color_name_p);
1003
1004   CONSOLE_HAS_METHOD (x, initialize_font_instance);
1005   CONSOLE_HAS_METHOD (x, mark_font_instance);
1006   CONSOLE_HAS_METHOD (x, print_font_instance);
1007   CONSOLE_HAS_METHOD (x, finalize_font_instance);
1008   CONSOLE_HAS_METHOD (x, font_instance_truename);
1009   CONSOLE_HAS_METHOD (x, font_instance_properties);
1010   CONSOLE_HAS_METHOD (x, list_fonts);
1011 #ifdef MULE
1012   CONSOLE_HAS_METHOD (x, find_charset_font);
1013   CONSOLE_HAS_METHOD (x, font_spec_matches_charset);
1014 #endif
1015 }
1016
1017 void
1018 vars_of_objects_x (void)
1019 {
1020   DEFVAR_BOOL ("x-handle-non-fully-specified-fonts",
1021                &x_handle_non_fully_specified_fonts /*
1022 If this is true then fonts which do not have all characters specified
1023 will be considered to be proportional width even if they are actually
1024 fixed-width.  If this is not done then characters which are supposed to
1025 have 0 width may appear to actually have some width.
1026
1027 Note:  While setting this to t guarantees correct output in all
1028 circumstances, it also causes a noticeable performance hit when using
1029 fixed-width fonts.  Since most people don't use characters which could
1030 cause problems this is set to nil by default.
1031 */ );
1032   x_handle_non_fully_specified_fonts = 0;
1033 }
1034
1035 void
1036 Xatoms_of_objects_x (struct device *d)
1037 {
1038   Display *D = DEVICE_X_DISPLAY (d);
1039
1040   DEVICE_XATOM_FOUNDRY         (d) = XInternAtom (D, "FOUNDRY",         False);
1041   DEVICE_XATOM_FAMILY_NAME     (d) = XInternAtom (D, "FAMILY_NAME",     False);
1042   DEVICE_XATOM_WEIGHT_NAME     (d) = XInternAtom (D, "WEIGHT_NAME",     False);
1043   DEVICE_XATOM_SLANT           (d) = XInternAtom (D, "SLANT",           False);
1044   DEVICE_XATOM_SETWIDTH_NAME   (d) = XInternAtom (D, "SETWIDTH_NAME",   False);
1045   DEVICE_XATOM_ADD_STYLE_NAME  (d) = XInternAtom (D, "ADD_STYLE_NAME",  False);
1046   DEVICE_XATOM_PIXEL_SIZE      (d) = XInternAtom (D, "PIXEL_SIZE",      False);
1047   DEVICE_XATOM_POINT_SIZE      (d) = XInternAtom (D, "POINT_SIZE",      False);
1048   DEVICE_XATOM_RESOLUTION_X    (d) = XInternAtom (D, "RESOLUTION_X",    False);
1049   DEVICE_XATOM_RESOLUTION_Y    (d) = XInternAtom (D, "RESOLUTION_Y",    False);
1050   DEVICE_XATOM_SPACING         (d) = XInternAtom (D, "SPACING",         False);
1051   DEVICE_XATOM_AVERAGE_WIDTH   (d) = XInternAtom (D, "AVERAGE_WIDTH",   False);
1052   DEVICE_XATOM_CHARSET_REGISTRY(d) = XInternAtom (D, "CHARSET_REGISTRY",False);
1053   DEVICE_XATOM_CHARSET_ENCODING(d) = XInternAtom (D, "CHARSET_ENCODING",False);
1054 }