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