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