Reformatted.
[chise/xemacs-chise.git] / 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, 2000 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 /* This file Mule-ized by Ben Wing, 7-10-00. */
30
31 #include <config.h>
32 #include "lisp.h"
33
34 #include "console-x.h"
35 #include "objects-x.h"
36
37 #include "buffer.h"
38 #include "device.h"
39 #include "insdel.h"
40
41 int x_handle_non_fully_specified_fonts;
42
43 \f
44 /************************************************************************/
45 /*                          color instances                             */
46 /************************************************************************/
47
48 /* Replacement for XAllocColor() that tries to return the nearest
49    available color if the colormap is full.  Original was from FSFmacs,
50    but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25
51    Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous
52    total failure which was due to a read/write colorcell being the nearest
53    match - tries the next nearest...
54
55    Return value is 1 for normal success, 2 for nearest color success,
56    3 for Non-deallocable success. */
57 int
58 allocate_nearest_color (Display *display, Colormap colormap, Visual *visual,
59                         XColor *color_def)
60 {
61   int status;
62
63   if (visual->class == DirectColor || visual->class == TrueColor)
64     {
65       if (XAllocColor (display, colormap, color_def) != 0)
66         {
67           status = 1;
68         }
69       else
70         {
71           /* We're dealing with a TrueColor/DirectColor visual, so play games
72              with the RGB values in the XColor struct. */
73           /* #### JH: I'm not sure how a call to XAllocColor can fail in a
74              TrueColor or DirectColor visual, so I will just reformat the
75              request to match the requirements of the visual, and re-issue
76              the request.  If this fails for anybody, I wanna know about it
77              so I can come up with a better plan */
78
79           unsigned long rshift,gshift,bshift,rbits,gbits,bbits,junk;
80           junk = visual->red_mask;
81           rshift = 0;
82           while ((junk & 0x1) == 0) {
83             junk = junk >> 1;
84             rshift ++;
85           }
86           rbits = 0;
87           while (junk != 0) {
88             junk = junk >> 1;
89             rbits++;
90           }
91           junk = visual->green_mask;
92           gshift = 0;
93           while ((junk & 0x1) == 0) {
94             junk = junk >> 1;
95             gshift ++;
96           }
97           gbits = 0;
98           while (junk != 0) {
99             junk = junk >> 1;
100             gbits++;
101           }
102           junk = visual->blue_mask;
103           bshift = 0;
104           while ((junk & 0x1) == 0) {
105             junk = junk >> 1;
106             bshift ++;
107           }
108           bbits = 0;
109           while (junk != 0) {
110             junk = junk >> 1;
111             bbits++;
112           }
113
114           color_def->red = color_def->red >> (16 - rbits);
115           color_def->green = color_def->green >> (16 - gbits);
116           color_def->blue = color_def->blue >> (16 - bbits);
117           if (XAllocColor (display, colormap, color_def) != 0)
118             status = 1;
119           else
120             {
121               int rd, gr, bl;
122               /* #### JH: I'm punting here, knowing that doing this will at
123                  least draw the color correctly.  However, unless we convert
124                  all of the functions that allocate colors (graphics
125                  libraries, etc) to use this function doing this is very
126                  likely to cause problems later... */
127
128               if (rbits > 8)
129                 rd = color_def->red << (rbits - 8);
130               else
131                 rd = color_def->red >> (8 - rbits);
132               if (gbits > 8)
133                 gr = color_def->green << (gbits - 8);
134               else
135                 gr = color_def->green >> (8 - gbits);
136               if (bbits > 8)
137                 bl = color_def->blue << (bbits - 8);
138               else
139                 bl = color_def->blue >> (8 - bbits);
140               color_def->pixel = (rd << rshift) | (gr << gshift) | (bl <<
141                                                                     bshift);
142               status = 3;
143             }
144         }
145     }
146   else
147     {
148       XColor *cells = NULL;
149       /* JH: I can't believe there's no way to go backwards from a
150          colormap ID and get its visual and number of entries, but X
151          apparently isn't built that way... */
152       int no_cells = visual->map_entries;
153       status = 0;
154
155       if (XAllocColor (display, colormap, color_def) != 0)
156         status = 1;
157       else while( status != 2 )
158         {
159           /* If we got to this point, the colormap is full, so we're
160              going to try and get the next closest color.  The algorithm used
161              is a least-squares matching, which is what X uses for closest
162              color matching with StaticColor visuals. */
163           int nearest;
164           long nearest_delta, trial_delta;
165           int x;
166
167           if( cells == NULL )
168             {
169               cells = alloca_array (XColor, no_cells);
170               for (x = 0; x < no_cells; x++)
171                 cells[x].pixel = x;
172
173               /* read the current colormap */
174               XQueryColors (display, colormap, cells, no_cells);
175             }
176
177           nearest = 0;
178           /* I'm assuming CSE so I'm not going to condense this. */
179           nearest_delta = ((((color_def->red >> 8) - (cells[0].red >> 8))
180                             * ((color_def->red >> 8) - (cells[0].red >> 8)))
181                            +
182                            (((color_def->green >> 8) - (cells[0].green >> 8))
183                             * ((color_def->green >> 8) - (cells[0].green >>
184                                                           8)))
185                            +
186                            (((color_def->blue >> 8) - (cells[0].blue >> 8))
187                             * ((color_def->blue >> 8) - (cells[0].blue >>
188                                                          8))));
189           for (x = 1; x < no_cells; x++)
190             {
191               trial_delta = ((((color_def->red >> 8) - (cells[x].red >> 8))
192                               * ((color_def->red >> 8) - (cells[x].red >> 8)))
193                              +
194                              (((color_def->green >> 8) - (cells[x].green >> 8))
195                               * ((color_def->green >> 8) - (cells[x].green >>
196                                                             8)))
197                              +
198                              (((color_def->blue >> 8) - (cells[x].blue >> 8))
199                               * ((color_def->blue >> 8) - (cells[x].blue >>
200                                                            8))));
201
202               /* less? Ignore cells marked as previously failing */
203               if( (trial_delta < nearest_delta) &&
204                   (cells[x].pixel != ULONG_MAX) )
205                 {
206                   nearest = x;
207                   nearest_delta = trial_delta;
208                 }
209             }
210           color_def->red = cells[nearest].red;
211           color_def->green = cells[nearest].green;
212           color_def->blue = cells[nearest].blue;
213           if (XAllocColor (display, colormap, color_def) != 0)
214             status = 2;
215           else
216             /* LSK: Either the colour map has changed since
217              * we read it, or the colour is allocated
218              * read/write... Mark this cmap entry so it's
219              * ignored in the next iteration.
220              */
221             cells[nearest].pixel = ULONG_MAX;
222         }
223     }
224   return status;
225 }
226
227 static int
228 x_parse_nearest_color (struct device *d, XColor *color, Lisp_Object name,
229                        Error_behavior errb)
230 {
231   Display *dpy   = DEVICE_X_DISPLAY  (d);
232   Colormap cmap  = DEVICE_X_COLORMAP (d);
233   Visual *visual = DEVICE_X_VISUAL   (d);
234   int result;
235
236   xzero (*color);
237   {
238     const Extbyte *extname;
239
240     LISP_STRING_TO_EXTERNAL (name, extname, Qx_color_name_encoding);
241     result = XParseColor (dpy, cmap, extname, color);
242   }
243   if (!result)
244     {
245       maybe_signal_simple_error ("Unrecognized color", name, Qcolor, errb);
246       return 0;
247     }
248   result = allocate_nearest_color (dpy, cmap, visual, color);
249   if (!result)
250     {
251       maybe_signal_simple_error ("Couldn't allocate color", name, Qcolor,
252                                  errb);
253       return 0;
254     }
255
256   return result;
257 }
258
259 static int
260 x_initialize_color_instance (Lisp_Color_Instance *c, Lisp_Object name,
261                              Lisp_Object device, Error_behavior errb)
262 {
263   XColor color;
264   int result;
265
266   result = x_parse_nearest_color (XDEVICE (device), &color, name, 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)),
304                            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   const Extbyte *extname;
353
354   LISP_STRING_TO_EXTERNAL (color, extname, Qx_color_name_encoding);
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 Extbyte *extname;
371
372   LISP_STRING_TO_EXTERNAL (f->name, extname, Qx_font_name_encoding);
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 bitstream 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 noncommittal 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, Extbyte *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   Extbyte **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 Extbyte *
590 truename_via_FONT_prop (Display *dpy, XFontStruct *font)
591 {
592   unsigned long value = 0;
593   Extbyte *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 Extbyte *
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   Extbyte *foundry, *family, *weight, *slant, *setwidth, *add_style;
615   unsigned long pixel, point, res_x, res_y;
616   Extbyte *spacing;
617   unsigned long avg_width;
618   Extbyte *registry, *encoding;
619   Extbyte composed_name [2048];
620   int ok = 0;
621   Extbyte *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 = (Extbyte *) 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 INT_MAX
685
686 static Extbyte *
687 truename_via_XListFonts (Display *dpy, Extbyte *font_name)
688 {
689   Extbyte *result = 0;
690   Extbyte **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     /* !!#### Not Mule-friendly */
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, Extbyte *name, XFontStruct *font)
719 {
720   Extbyte *truename_FONT = 0;
721   Extbyte *truename_random = 0;
722   Extbyte *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_ext_string (truename, Qx_font_name_encoding);
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       {
784         Extbyte *nameext;
785
786         LISP_STRING_TO_EXTERNAL (f->name, nameext, Qx_font_name_encoding);
787         FONT_INSTANCE_X_TRUENAME (f) =
788           x_font_truename (dpy, nameext, FONT_INSTANCE_X_FONT (f));
789       }
790       if (NILP (FONT_INSTANCE_X_TRUENAME (f)))
791         {
792           Lisp_Object font_instance;
793           XSETFONT_INSTANCE (font_instance, f);
794
795           maybe_signal_simple_error ("Couldn't determine font truename",
796                                      font_instance, Qfont, errb);
797           /* Ok, just this once, return the font name as the truename.
798              (This is only used by Fequal() right now.) */
799           return f->name;
800         }
801     }
802   return FONT_INSTANCE_X_TRUENAME (f);
803 }
804
805 static Lisp_Object
806 x_font_instance_properties (Lisp_Font_Instance *f)
807 {
808   struct device *d = XDEVICE (f->device);
809   int i;
810   Lisp_Object result = Qnil;
811   Display *dpy = DEVICE_X_DISPLAY (d);
812   XFontProp *props = FONT_INSTANCE_X_FONT (f)->properties;
813
814   for (i = FONT_INSTANCE_X_FONT (f)->n_properties - 1; i >= 0; i--)
815     {
816       Lisp_Object name, value;
817       Atom atom = props [i].name;
818       Bufbyte *name_str = 0;
819       size_t name_len;
820       Extbyte *namestrext = XGetAtomName (dpy, atom);
821
822       if (namestrext)
823         TO_INTERNAL_FORMAT (C_STRING, namestrext,
824                             ALLOCA, (name_str, name_len),
825                             Qx_atom_name_encoding);
826
827       name = (name_str ? intern ((char *) name_str) : Qnil);
828       if (name_str &&
829           (atom == XA_FONT ||
830            atom == DEVICE_XATOM_FOUNDRY (d) ||
831            atom == DEVICE_XATOM_FAMILY_NAME (d) ||
832            atom == DEVICE_XATOM_WEIGHT_NAME (d) ||
833            atom == DEVICE_XATOM_SLANT (d) ||
834            atom == DEVICE_XATOM_SETWIDTH_NAME (d) ||
835            atom == DEVICE_XATOM_ADD_STYLE_NAME (d) ||
836            atom == DEVICE_XATOM_SPACING (d) ||
837            atom == DEVICE_XATOM_CHARSET_REGISTRY (d) ||
838            atom == DEVICE_XATOM_CHARSET_ENCODING (d) ||
839            !bufbyte_strcmp (name_str, "CHARSET_COLLECTIONS") ||
840            !bufbyte_strcmp (name_str, "FONTNAME_REGISTRY") ||
841            !bufbyte_strcmp (name_str, "CLASSIFICATION") ||
842            !bufbyte_strcmp (name_str, "COPYRIGHT") ||
843            !bufbyte_strcmp (name_str, "DEVICE_FONT_NAME") ||
844            !bufbyte_strcmp (name_str, "FULL_NAME") ||
845            !bufbyte_strcmp (name_str, "MONOSPACED") ||
846            !bufbyte_strcmp (name_str, "QUALITY") ||
847            !bufbyte_strcmp (name_str, "RELATIVE_SET") ||
848            !bufbyte_strcmp (name_str, "RELATIVE_WEIGHT") ||
849            !bufbyte_strcmp (name_str, "STYLE")))
850         {
851           Extbyte *val_str = XGetAtomName (dpy, props [i].card32);
852
853           value = (val_str ? build_ext_string (val_str, Qx_atom_name_encoding)
854                    : Qnil);
855         }
856       else
857         value = make_int (props [i].card32);
858       if (namestrext) XFree (namestrext);
859       result = Fcons (Fcons (name, value), result);
860     }
861   return result;
862 }
863
864 static Lisp_Object
865 x_list_fonts (Lisp_Object pattern, Lisp_Object device)
866 {
867   Extbyte **names;
868   int count = 0;
869   Lisp_Object result = Qnil;
870   const Extbyte *patternext;
871
872   LISP_STRING_TO_EXTERNAL (pattern, patternext, Qx_font_name_encoding);
873
874   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
875                       patternext, MAX_FONT_COUNT, &count);
876   while (count--)
877     result = Fcons (build_ext_string (names[count], Qx_font_name_encoding),
878                     result);
879   if (names)
880     XFreeFontNames (names);
881   return result;
882 }
883
884 #ifdef MULE
885
886 static int
887 x_font_spec_matches_charset (struct device *d, Lisp_Object charset,
888                              const Bufbyte *nonreloc, Lisp_Object reloc,
889                              Bytecount offset, Bytecount length)
890 {
891   if (UNBOUNDP (charset))
892     return 1;
893   /* Hack! Short font names don't have the registry in them,
894      so we just assume the user knows what they're doing in the
895      case of ASCII.  For other charsets, you gotta give the
896      long form; sorry buster.
897      */
898   if (EQ (charset, Vcharset_ascii))
899     {
900       const Bufbyte *the_nonreloc = nonreloc;
901       int i;
902       Bytecount the_length = length;
903
904       if (!the_nonreloc)
905         the_nonreloc = XSTRING_DATA (reloc);
906       fixup_internal_substring (nonreloc, reloc, offset, &the_length);
907       the_nonreloc += offset;
908       if (!memchr (the_nonreloc, '*', the_length))
909         {
910           for (i = 0;; i++)
911             {
912               const Bufbyte *new_nonreloc = (const Bufbyte *)
913                 memchr (the_nonreloc, '-', the_length);
914               if (!new_nonreloc)
915                 break;
916               new_nonreloc++;
917               the_length -= new_nonreloc - the_nonreloc;
918               the_nonreloc = new_nonreloc;
919             }
920
921           /* If it has less than 5 dashes, it's a short font.
922              Of course, long fonts always have 14 dashes or so, but short
923              fonts never have more than 1 or 2 dashes, so this is some
924              sort of reasonable heuristic. */
925           if (i < 5)
926             return 1;
927         }
928     }
929
930   return (fast_string_match (XCHARSET_REGISTRY (charset),
931                              nonreloc, reloc, offset, length, 1,
932                              ERROR_ME, 0) >= 0);
933 }
934
935 /* find a font spec that matches font spec FONT and also matches
936    (the registry of) CHARSET. */
937 static Lisp_Object
938 x_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
939 {
940   Extbyte **names;
941   int count = 0;
942   Lisp_Object result = Qnil;
943   const Extbyte *patternext;
944   int i;
945
946   LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding);
947
948   names = XListFonts (DEVICE_X_DISPLAY (XDEVICE (device)),
949                       patternext, MAX_FONT_COUNT, &count);
950   /* #### This code seems awfully bogus -- mrb */
951   for (i = 0; i < count; i ++)
952     {
953       const Bufbyte *intname;
954       Bytecount intlen;
955
956       TO_INTERNAL_FORMAT (C_STRING, names[i],
957                           ALLOCA, (intname, intlen),
958                           Qx_font_name_encoding);
959       if (x_font_spec_matches_charset (XDEVICE (device), charset,
960                                        intname, Qnil, 0, -1))
961         {
962           result = make_string (intname, intlen);
963           break;
964         }
965     }
966
967   if (names)
968     XFreeFontNames (names);
969
970   /* Check for a short font name. */
971   if (NILP (result)
972       && x_font_spec_matches_charset (XDEVICE (device), charset, 0,
973                                       font, 0, -1))
974     return font;
975
976   return result;
977 }
978
979 #endif /* MULE */
980
981 \f
982 /************************************************************************/
983 /*                            initialization                            */
984 /************************************************************************/
985
986 void
987 syms_of_objects_x (void)
988 {
989 }
990
991 void
992 console_type_create_objects_x (void)
993 {
994   /* object methods */
995
996   CONSOLE_HAS_METHOD (x, initialize_color_instance);
997   CONSOLE_HAS_METHOD (x, print_color_instance);
998   CONSOLE_HAS_METHOD (x, finalize_color_instance);
999   CONSOLE_HAS_METHOD (x, color_instance_equal);
1000   CONSOLE_HAS_METHOD (x, color_instance_hash);
1001   CONSOLE_HAS_METHOD (x, color_instance_rgb_components);
1002   CONSOLE_HAS_METHOD (x, valid_color_name_p);
1003
1004   CONSOLE_HAS_METHOD (x, initialize_font_instance);
1005   CONSOLE_HAS_METHOD (x, mark_font_instance);
1006   CONSOLE_HAS_METHOD (x, print_font_instance);
1007   CONSOLE_HAS_METHOD (x, finalize_font_instance);
1008   CONSOLE_HAS_METHOD (x, font_instance_truename);
1009   CONSOLE_HAS_METHOD (x, font_instance_properties);
1010   CONSOLE_HAS_METHOD (x, list_fonts);
1011 #ifdef MULE
1012   CONSOLE_HAS_METHOD (x, find_charset_font);
1013   CONSOLE_HAS_METHOD (x, font_spec_matches_charset);
1014 #endif
1015 }
1016
1017 void
1018 vars_of_objects_x (void)
1019 {
1020   DEFVAR_BOOL ("x-handle-non-fully-specified-fonts",
1021                &x_handle_non_fully_specified_fonts /*
1022 If this is true then fonts which do not have all characters specified
1023 will be considered to be proportional width even if they are actually
1024 fixed-width.  If this is not done then characters which are supposed to
1025 have 0 width may appear to actually have some width.
1026
1027 Note:  While setting this to t guarantees correct output in all
1028 circumstances, it also causes a noticeable performance hit when using
1029 fixed-width fonts.  Since most people don't use characters which could
1030 cause problems this is set to nil by default.
1031 */ );
1032   x_handle_non_fully_specified_fonts = 0;
1033 }
1034
1035 void
1036 Xatoms_of_objects_x (struct device *d)
1037 {
1038   Display *D = DEVICE_X_DISPLAY (d);
1039
1040   DEVICE_XATOM_FOUNDRY         (d) = XInternAtom (D, "FOUNDRY",         False);
1041   DEVICE_XATOM_FAMILY_NAME     (d) = XInternAtom (D, "FAMILY_NAME",     False);
1042   DEVICE_XATOM_WEIGHT_NAME     (d) = XInternAtom (D, "WEIGHT_NAME",     False);
1043   DEVICE_XATOM_SLANT           (d) = XInternAtom (D, "SLANT",           False);
1044   DEVICE_XATOM_SETWIDTH_NAME   (d) = XInternAtom (D, "SETWIDTH_NAME",   False);
1045   DEVICE_XATOM_ADD_STYLE_NAME  (d) = XInternAtom (D, "ADD_STYLE_NAME",  False);
1046   DEVICE_XATOM_PIXEL_SIZE      (d) = XInternAtom (D, "PIXEL_SIZE",      False);
1047   DEVICE_XATOM_POINT_SIZE      (d) = XInternAtom (D, "POINT_SIZE",      False);
1048   DEVICE_XATOM_RESOLUTION_X    (d) = XInternAtom (D, "RESOLUTION_X",    False);
1049   DEVICE_XATOM_RESOLUTION_Y    (d) = XInternAtom (D, "RESOLUTION_Y",    False);
1050   DEVICE_XATOM_SPACING         (d) = XInternAtom (D, "SPACING",         False);
1051   DEVICE_XATOM_AVERAGE_WIDTH   (d) = XInternAtom (D, "AVERAGE_WIDTH",   False);
1052   DEVICE_XATOM_CHARSET_REGISTRY(d) = XInternAtom (D, "CHARSET_REGISTRY",False);
1053   DEVICE_XATOM_CHARSET_ENCODING(d) = XInternAtom (D, "CHARSET_ENCODING",False);
1054 }