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     GET_CHARPTR_EXT_BINARY_DATA_ALLOCA (name, len, extname, extnamelen);
 236     result = XParseColor (dpy, cmap, (char *) extname, color);
 237   }
 238   if (!result)
 239     {
 240       maybe_signal_simple_error ("Unrecognized color", make_string (name, len),
 241                                  Qcolor, errb);
 242       return 0;
 243     }
 244   result = allocate_nearest_color (dpy, cmap, visual, color);
 245   if (!result)
 246     {
 247       maybe_signal_simple_error ("Couldn't allocate color",
 248                                  make_string (name, len), Qcolor, errb);
 249       return 0;
 250     }
 251
 252   return result;
 253 }
 254
 255 static int
 256 x_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
 257                              Lisp_Object device, Error_behavior errb)
 258 {
 259   XColor color;
 260   int result;
 261
 262   result = x_parse_nearest_color (XDEVICE (device), &color,
 263                                   XSTRING_DATA   (name),
 264                                   XSTRING_LENGTH (name),
 265                                   errb);
 266
 267   if (!result)
 268     return 0;
 269
 270   /* Don't allocate the data until we're sure that we will succeed,
 271      or the finalize method may get fucked. */
 272   c->data = xnew (struct x_color_instance_data);
 273   if (result == 3)
 274     COLOR_INSTANCE_X_DEALLOC (c) = 0;
 275   else
 276     COLOR_INSTANCE_X_DEALLOC (c) = 1;
 277   COLOR_INSTANCE_X_COLOR (c) = color;
 278   return 1;
 279 }
 280
 281 static void
 282 x_print_color_instance (struct Lisp_Color_Instance *c,
 283                         Lisp_Object printcharfun,
 284                         int escapeflag)
 285 {
 286   char buf[100];
 287   XColor color = COLOR_INSTANCE_X_COLOR (c);
 288   sprintf (buf, " %ld=(%X,%X,%X)",
 289            color.pixel, color.red, color.green, color.blue);
 290   write_c_string (buf, printcharfun);
 291 }
 292
 293 static void
 294 x_finalize_color_instance (struct Lisp_Color_Instance *c)
 295 {
 296   if (c->data)
 297     {
 298       if (DEVICE_LIVE_P (XDEVICE (c->device)))
 299         {
 300           if (COLOR_INSTANCE_X_DEALLOC (c))
 301             {
 302               XFreeColors (DEVICE_X_DISPLAY (XDEVICE (c->device)), DEVICE_X_COLORMAP (XDEVICE (c->device)),
 303                            &COLOR_INSTANCE_X_COLOR (c).pixel, 1, 0);
 304             }
 305         }
 306       xfree (c->data);
 307       c->data = 0;
 308     }
 309 }
 310
 311 /* Color instances are equal if they resolve to the same color on the
 312    screen (have the same RGB values).  I imagine that
 313    "same RGB values" == "same cell in the colormap."  Arguably we should
 314    be comparing their names or pixel values instead. */
 315
 316 static int
 317 x_color_instance_equal (struct Lisp_Color_Instance *c1,
 318                         struct Lisp_Color_Instance *c2,
 319                         int depth)
 320 {
 321   XColor color1 = COLOR_INSTANCE_X_COLOR (c1);
 322   XColor color2 = COLOR_INSTANCE_X_COLOR (c2);
 323   return ((color1.red == color2.red) &&
 324           (color1.green == color2.green) &&
 325           (color1.blue == color2.blue));
 326 }
 327
 328 static unsigned long
 329 x_color_instance_hash (struct Lisp_Color_Instance *c, int depth)
 330 {
 331   XColor color = COLOR_INSTANCE_X_COLOR (c);
 332   return HASH3 (color.red, color.green, color.blue);
 333 }
 334
 335 static Lisp_Object
 336 x_color_instance_rgb_components (struct Lisp_Color_Instance *c)
 337 {
 338   XColor color = COLOR_INSTANCE_X_COLOR (c);
 339   return (list3 (make_int (color.red),
 340                  make_int (color.green),
 341                  make_int (color.blue)));
 342 }
 343
 344 static int
 345 x_valid_color_name_p (struct device *d, Lisp_Object color)
 346 {
 347   XColor c;
 348   Display *dpy = DEVICE_X_DISPLAY (d);
 349   Colormap cmap = DEVICE_X_COLORMAP (d);
 350
 351   CONST char *extname;
 352
 353   GET_C_STRING_CTEXT_DATA_ALLOCA (color, extname);
 354
 355   return XParseColor (dpy, cmap,
 356                       extname, &c);
 357 }
 358
 359 \f
 360 /************************************************************************/
 361 /*                           font instances                             */
 362 /************************************************************************/
 363
 364 static int
 365 x_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name,
 366                             Lisp_Object device, Error_behavior errb)
 367 {
 368   Display *dpy;
 369   XFontStruct *xf;
 370   CONST char *extname;
 371
 372   dpy = DEVICE_X_DISPLAY (XDEVICE (device));
 373   GET_C_STRING_CTEXT_DATA_ALLOCA (f->name, extname);
 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 (struct Lisp_Font_Instance *f)
 461 {
 462   mark_object (FONT_INSTANCE_X_TRUENAME (f));
 463 }
 464
 465 static void
 466 x_print_font_instance (struct 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 (struct 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 (struct 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 (struct 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   GET_C_STRING_BINARY_DATA_ALLOCA (pattern, patternext);
 865
 866   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
 867                       patternext, MAX_FONT_COUNT, &count);
 868   while (count--)
 869     result = Fcons (build_ext_string (names [count], FORMAT_BINARY), result);
 870   if (names)
 871     XFreeFontNames (names);
 872   return result;
 873 }
 874
 875 #ifdef MULE
 876
 877 static int
 878 x_font_spec_matches_charset (struct device *d, Lisp_Object charset,
 879                              CONST Bufbyte *nonreloc, Lisp_Object reloc,
 880                              Bytecount offset, Bytecount length)
 881 {
 882   if (UNBOUNDP (charset))
 883     return 1;
 884   /* Hack! Short font names don't have the registry in them,
 885      so we just assume the user knows what they're doing in the
 886      case of ASCII.  For other charsets, you gotta give the
 887      long form; sorry buster.
 888      */
 889   if (EQ (charset, Vcharset_ascii))
 890     {
 891       CONST Bufbyte *the_nonreloc = nonreloc;
 892       int i;
 893       Bytecount the_length = length;
 894
 895       if (!the_nonreloc)
 896         the_nonreloc = XSTRING_DATA (reloc);
 897       fixup_internal_substring (nonreloc, reloc, offset, &the_length);
 898       the_nonreloc += offset;
 899       if (!memchr (the_nonreloc, '*', the_length))
 900         {
 901           for (i = 0;; i++)
 902             {
 903               CONST Bufbyte *new_nonreloc = (CONST Bufbyte *)
 904                 memchr (the_nonreloc, '-', the_length);
 905               if (!new_nonreloc)
 906                 break;
 907               new_nonreloc++;
 908               the_length -= new_nonreloc - the_nonreloc;
 909               the_nonreloc = new_nonreloc;
 910             }
 911
 912           /* If it has less than 5 dashes, it's a short font.
 913              Of course, long fonts always have 14 dashes or so, but short
 914              fonts never have more than 1 or 2 dashes, so this is some
 915              sort of reasonable heuristic. */
 916           if (i < 5)
 917             return 1;
 918         }
 919     }
 920
 921   return (fast_string_match (XCHARSET_REGISTRY (charset),
 922                              nonreloc, reloc, offset, length, 1,
 923                              ERROR_ME, 0) >= 0);
 924 }
 925
 926 /* find a font spec that matches font spec FONT and also matches
 927    (the registry of) CHARSET. */
 928 static Lisp_Object
 929 x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
 930 {
 931   char **names;
 932   int count = 0;
 933   Lisp_Object result = Qnil;
 934   CONST char *patternext;
 935   int i;
 936
 937   GET_C_STRING_BINARY_DATA_ALLOCA (font, patternext);
 938
 939   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
 940                       patternext, MAX_FONT_COUNT, &count);
 941   /* ### This code seems awfully bogus -- mrb */
 942   for (i = 0; i < count; i ++)
 943     {
 944       CONST Bufbyte *intname;
 945
 946       GET_C_CHARPTR_INT_BINARY_DATA_ALLOCA (names[i], intname);
 947       if (x_font_spec_matches_charset (XDEVICE (device), charset,
 948                                        intname, Qnil, 0, -1))
 949         {
 950           result = build_string ((char *) intname);
 951           break;
 952         }
 953     }
 954
 955   if (names)
 956     XFreeFontNames (names);
 957
 958   /* Check for a short font name. */
 959   if (NILP (result)
 960       && x_font_spec_matches_charset (XDEVICE (device), charset, 0,
 961                                       font, 0, -1))
 962     return font;
 963
 964   return result;
 965 }
 966
 967 #endif /* MULE */
 968
 969 \f
 970 /************************************************************************/
 971 /*                            initialization                            */
 972 /************************************************************************/
 973
 974 void
 975 syms_of_objects_x (void)
 976 {
 977 }
 978
 979 void
 980 console_type_create_objects_x (void)
 981 {
 982   /* object methods */
 983
 984   CONSOLE_HAS_METHOD (x, initialize_color_instance);
 985   CONSOLE_HAS_METHOD (x, print_color_instance);
 986   CONSOLE_HAS_METHOD (x, finalize_color_instance);
 987   CONSOLE_HAS_METHOD (x, color_instance_equal);
 988   CONSOLE_HAS_METHOD (x, color_instance_hash);
 989   CONSOLE_HAS_METHOD (x, color_instance_rgb_components);
 990   CONSOLE_HAS_METHOD (x, valid_color_name_p);
 991
 992   CONSOLE_HAS_METHOD (x, initialize_font_instance);
 993   CONSOLE_HAS_METHOD (x, mark_font_instance);
 994   CONSOLE_HAS_METHOD (x, print_font_instance);
 995   CONSOLE_HAS_METHOD (x, finalize_font_instance);
 996   CONSOLE_HAS_METHOD (x, font_instance_truename);
 997   CONSOLE_HAS_METHOD (x, font_instance_properties);
 998   CONSOLE_HAS_METHOD (x, list_fonts);
 999 #ifdef MULE
1000   CONSOLE_HAS_METHOD (x, find_charset_font);
1001   CONSOLE_HAS_METHOD (x, font_spec_matches_charset);
1002 #endif
1003 }
1004
1005 void
1006 vars_of_objects_x (void)
1007 {
1008   DEFVAR_BOOL ("x-handle-non-fully-specified-fonts",
1009                &x_handle_non_fully_specified_fonts /*
1010 If this is true then fonts which do not have all characters specified
1011 will be considered to be proportional width even if they are actually
1012 fixed-width.  If this is not done then characters which are supposed to
1013 have 0 width may appear to actually have some width.
1014
1015 Note:  While setting this to t guarantees correct output in all
1016 circumstances, it also causes a noticeable performance hit when using
1017 fixed-width fonts.  Since most people don't use characters which could
1018 cause problems this is set to nil by default.
1019 */ );
1020   x_handle_non_fully_specified_fonts = 0;
1021 }
1022
1023 void
1024 Xatoms_of_objects_x (struct device *d)
1025 {
1026   Display *D = DEVICE_X_DISPLAY (d);
1027
1028   DEVICE_XATOM_FOUNDRY         (d) = XInternAtom (D, "FOUNDRY",         False);
1029   DEVICE_XATOM_FAMILY_NAME     (d) = XInternAtom (D, "FAMILY_NAME",     False);
1030   DEVICE_XATOM_WEIGHT_NAME     (d) = XInternAtom (D, "WEIGHT_NAME",     False);
1031   DEVICE_XATOM_SLANT           (d) = XInternAtom (D, "SLANT",           False);
1032   DEVICE_XATOM_SETWIDTH_NAME   (d) = XInternAtom (D, "SETWIDTH_NAME",   False);
1033   DEVICE_XATOM_ADD_STYLE_NAME  (d) = XInternAtom (D, "ADD_STYLE_NAME",  False);
1034   DEVICE_XATOM_PIXEL_SIZE      (d) = XInternAtom (D, "PIXEL_SIZE",      False);
1035   DEVICE_XATOM_POINT_SIZE      (d) = XInternAtom (D, "POINT_SIZE",      False);
1036   DEVICE_XATOM_RESOLUTION_X    (d) = XInternAtom (D, "RESOLUTION_X",    False);
1037   DEVICE_XATOM_RESOLUTION_Y    (d) = XInternAtom (D, "RESOLUTION_Y",    False);
1038   DEVICE_XATOM_SPACING         (d) = XInternAtom (D, "SPACING",         False);
1039   DEVICE_XATOM_AVERAGE_WIDTH   (d) = XInternAtom (D, "AVERAGE_WIDTH",   False);
1040   DEVICE_XATOM_CHARSET_REGISTRY(d) = XInternAtom (D, "CHARSET_REGISTRY",False);
1041   DEVICE_XATOM_CHARSET_ENCODING(d) = XInternAtom (D, "CHARSET_ENCODING",False);
1042 }