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