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