Reformatted.
[chise/xemacs-chise.git.1] / src / objects-gtk.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 /* Gtk version by William Perry */
29
30 #include <config.h>
31 #include "lisp.h"
32
33 #include "console-gtk.h"
34 #include "objects-gtk.h"
35
36 #include "buffer.h"
37 #include "device.h"
38 #include "insdel.h"
39
40 /* sigh */
41 #include <gdk/gdkx.h>
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    Gdk takes care of all this behind the scenes, so we don't need to
56    worry about it.
57
58    Return value is 1 for normal success, 2 for nearest color success,
59    3 for Non-deallocable sucess. */
60 int
61 allocate_nearest_color (GdkColormap *colormap, GdkVisual *visual,
62                         GdkColor *color_def)
63 {
64   int rc;
65
66   rc = gdk_colormap_alloc_color (colormap, color_def, FALSE, TRUE);
67
68   if (rc == TRUE)
69       return (1);
70
71   return (0);
72 }
73
74 int
75 gtk_parse_nearest_color (struct device *d, GdkColor *color, Bufbyte *name,
76                          Bytecount len, Error_behavior errb)
77 {
78   GdkColormap *cmap;
79   GdkVisual *visual;
80   int result;
81
82   cmap = DEVICE_GTK_COLORMAP(d);
83   visual = DEVICE_GTK_VISUAL (d);
84
85   xzero (*color);
86   {
87     const Extbyte *extname;
88     Extcount extnamelen;
89
90     TO_EXTERNAL_FORMAT (DATA, (name, len), ALLOCA, (extname, extnamelen), Qbinary);
91
92     result = gdk_color_parse (extname, color);
93   }
94   
95   if (result == FALSE)
96     {
97       maybe_signal_simple_error ("unrecognized color", make_string (name, len),
98                                  Qcolor, errb);
99       return 0;
100     }
101   result = allocate_nearest_color (cmap, visual, color);
102   if (!result)
103     {
104       maybe_signal_simple_error ("couldn't allocate color",
105                                  make_string (name, len), Qcolor, errb);
106       return 0;
107     }
108
109   return result;
110 }
111
112 static int
113 gtk_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
114                                Lisp_Object device, Error_behavior errb)
115 {
116   GdkColor color;
117   int result;
118
119   result = gtk_parse_nearest_color (XDEVICE (device), &color,
120                                     XSTRING_DATA   (name),
121                                     XSTRING_LENGTH (name),
122                                     errb);
123
124   if (!result)
125     return 0;
126
127   /* Don't allocate the data until we're sure that we will succeed,
128      or the finalize method may get fucked. */
129   c->data = xnew (struct gtk_color_instance_data);
130   if (result == 3)
131     COLOR_INSTANCE_GTK_DEALLOC (c) = 0;
132   else
133     COLOR_INSTANCE_GTK_DEALLOC (c) = 1;
134   COLOR_INSTANCE_GTK_COLOR (c) = gdk_color_copy (&color);
135   return 1;
136 }
137
138 static void
139 gtk_print_color_instance (struct Lisp_Color_Instance *c,
140                           Lisp_Object printcharfun,
141                           int escapeflag)
142 {
143   char buf[100];
144   GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
145   sprintf (buf, " %ld=(%X,%X,%X)",
146            color->pixel, color->red, color->green, color->blue);
147   write_c_string (buf, printcharfun);
148 }
149
150 static void
151 gtk_finalize_color_instance (struct Lisp_Color_Instance *c)
152 {
153   if (c->data)
154     {
155       if (DEVICE_LIVE_P (XDEVICE (c->device)))
156         {
157           if (COLOR_INSTANCE_GTK_DEALLOC (c))
158             {
159                 gdk_colormap_free_colors (DEVICE_GTK_COLORMAP (XDEVICE (c->device)),
160                                           COLOR_INSTANCE_GTK_COLOR (c), 1);
161             }
162             gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c));
163         }
164       xfree (c->data);
165       c->data = 0;
166     }
167 }
168
169 /* Color instances are equal if they resolve to the same color on the
170    screen (have the same RGB values).  I imagine that
171    "same RGB values" == "same cell in the colormap."  Arguably we should
172    be comparing their names or pixel values instead. */
173
174 static int
175 gtk_color_instance_equal (struct Lisp_Color_Instance *c1,
176                           struct Lisp_Color_Instance *c2,
177                           int depth)
178 {
179     return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1),
180                              COLOR_INSTANCE_GTK_COLOR (c2)));
181 }
182
183 static unsigned long
184 gtk_color_instance_hash (struct Lisp_Color_Instance *c, int depth)
185 {
186     return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL));
187 }
188
189 static Lisp_Object
190 gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c)
191 {
192   GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
193   return (list3 (make_int (color->red),
194                  make_int (color->green),
195                  make_int (color->blue)));
196 }
197
198 static int
199 gtk_valid_color_name_p (struct device *d, Lisp_Object color)
200 {
201   GdkColor c;
202   const char *extname;
203
204   TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext);
205
206   if (gdk_color_parse (extname, &c) != TRUE)
207       return(0);
208   return (1);
209 }
210
211 \f
212 /************************************************************************/
213 /*                           font instances                             */
214 /************************************************************************/
215
216 static int
217 gtk_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name,
218                               Lisp_Object device, Error_behavior errb)
219 {
220   GdkFont *gf;
221   XFontStruct *xf;
222   const char *extname;
223
224   TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext);
225
226   gf = gdk_font_load (extname);
227
228   if (!gf)
229     {
230       maybe_signal_simple_error ("couldn't load font", f->name,
231                                  Qfont, errb);
232       return 0;
233     }
234
235   xf = GDK_FONT_XFONT (gf);
236
237   /* Don't allocate the data until we're sure that we will succeed,
238      or the finalize method may get fucked. */
239   f->data = xnew (struct gtk_font_instance_data);
240   FONT_INSTANCE_GTK_TRUENAME (f) = Qnil;
241   FONT_INSTANCE_GTK_FONT (f) = gf;
242   f->ascent = gf->ascent;
243   f->descent = gf->descent;
244   f->height = gf->ascent + gf->descent;
245
246   /* Now lets figure out the width of the font */
247   {
248     /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */
249     unsigned int def_char = 'n'; /*xf->default_char;*/
250     unsigned int byte1, byte2;
251
252   once_more:
253     byte1 = def_char >> 8;
254     byte2 = def_char & 0xFF;
255
256     if (xf->per_char)
257       {
258         /* Old versions of the R5 font server have garbage (>63k) as
259            def_char. 'n' might not be a valid character. */
260         if (byte1 < xf->min_byte1         ||
261             byte1 > xf->max_byte1         ||
262             byte2 < xf->min_char_or_byte2 ||
263             byte2 > xf->max_char_or_byte2)
264           f->width = 0;
265         else
266           f->width = xf->per_char[(byte1 - xf->min_byte1) *
267                                   (xf->max_char_or_byte2 -
268                                    xf->min_char_or_byte2 + 1) +
269                                   (byte2 - xf->min_char_or_byte2)].width;
270       }
271     else
272       f->width = xf->max_bounds.width;
273
274     /* Some fonts have a default char whose width is 0.  This is no good.
275        If that's the case, first try 'n' as the default char, and if n has
276        0 width too (unlikely) then just use the max width. */
277     if (f->width == 0)
278       {
279         if (def_char == xf->default_char)
280           f->width = xf->max_bounds.width;
281         else
282           {
283             def_char = xf->default_char;
284             goto once_more;
285           }
286       }
287   }
288
289   /* If all characters don't exist then there could potentially be
290      0-width characters lurking out there.  Not setting this flag
291      trips an optimization that would make them appear to have width
292      to redisplay.  This is bad.  So we set it if not all characters
293      have the same width or if not all characters are defined.
294      */
295   /* #### This sucks.  There is a measurable performance increase
296      when using proportional width fonts if this flag is not set.
297      Unfortunately so many of the fucking X fonts are not fully
298      defined that we could almost just get rid of this damn flag and
299      make it an assertion. */
300   f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width ||
301                        (/* x_handle_non_fully_specified_fonts */ 0 &&
302                         !xf->all_chars_exist));
303 #if 0
304   f->width = gdk_char_width (gf, 'n');
305   f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W')) ? 1 : 0;
306 #endif
307   return 1;
308 }
309
310 static void
311 gtk_mark_font_instance (struct Lisp_Font_Instance *f)
312 {
313   mark_object (FONT_INSTANCE_GTK_TRUENAME (f));
314 }
315
316 static void
317 gtk_print_font_instance (struct Lisp_Font_Instance *f,
318                          Lisp_Object printcharfun,
319                          int escapeflag)
320 {
321   char buf[200];
322   sprintf (buf, " 0x%lx", (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f)));
323   write_c_string (buf, printcharfun);
324 }
325
326 static void
327 gtk_finalize_font_instance (struct Lisp_Font_Instance *f)
328 {
329   if (f->data)
330     {
331       if (DEVICE_LIVE_P (XDEVICE (f->device)))
332         {
333             gdk_font_unref (FONT_INSTANCE_GTK_FONT (f));
334         }
335       xfree (f->data);
336       f->data = 0;
337     }
338 }
339
340 /* Forward declarations for X specific functions at the end of the file */
341 Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp);
342 static Lisp_Object __gtk_list_fonts_internal (const char *pattern);
343
344 static Lisp_Object
345 gtk_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb)
346 {
347   if (NILP (FONT_INSTANCE_GTK_TRUENAME (f)))
348     {
349       FONT_INSTANCE_GTK_TRUENAME (f) = __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1);
350
351       if (NILP (FONT_INSTANCE_GTK_TRUENAME (f)))
352         {
353           /* Ok, just this once, return the font name as the truename.
354              (This is only used by Fequal() right now.) */
355           return f->name;
356         }
357     }
358   return (FONT_INSTANCE_GTK_TRUENAME (f));
359 }
360
361 static Lisp_Object
362 gtk_font_instance_properties (struct Lisp_Font_Instance *f)
363 {
364   Lisp_Object result = Qnil;
365
366   /* #### BILL!!! */
367   /* There seems to be no way to get this information under Gtk */
368   return result;
369 }
370
371 static Lisp_Object
372 gtk_list_fonts (Lisp_Object pattern, Lisp_Object device)
373 {
374   const char *patternext;
375
376   TO_EXTERNAL_FORMAT (LISP_STRING, pattern, C_STRING_ALLOCA, patternext, Qbinary);
377
378   return (__gtk_list_fonts_internal (patternext));
379 }
380
381 #ifdef MULE
382
383 static int
384 gtk_font_spec_matches_charset (struct device *d, Lisp_Object charset,
385                                const Bufbyte *nonreloc, Lisp_Object reloc,
386                                Bytecount offset, Bytecount length)
387 {
388   if (UNBOUNDP (charset))
389     return 1;
390   /* Hack! Short font names don't have the registry in them,
391      so we just assume the user knows what they're doing in the
392      case of ASCII.  For other charsets, you gotta give the
393      long form; sorry buster.
394      */
395   if (EQ (charset, Vcharset_ascii))
396     {
397       const Bufbyte *the_nonreloc = nonreloc;
398       int i;
399       Bytecount the_length = length;
400
401       if (!the_nonreloc)
402         the_nonreloc = XSTRING_DATA (reloc);
403       fixup_internal_substring (nonreloc, reloc, offset, &the_length);
404       the_nonreloc += offset;
405       if (!memchr (the_nonreloc, '*', the_length))
406         {
407           for (i = 0;; i++)
408             {
409               const Bufbyte *new_nonreloc = (const Bufbyte *)
410                 memchr (the_nonreloc, '-', the_length);
411               if (!new_nonreloc)
412                 break;
413               new_nonreloc++;
414               the_length -= new_nonreloc - the_nonreloc;
415               the_nonreloc = new_nonreloc;
416             }
417
418           /* If it has less than 5 dashes, it's a short font.
419              Of course, long fonts always have 14 dashes or so, but short
420              fonts never have more than 1 or 2 dashes, so this is some
421              sort of reasonable heuristic. */
422           if (i < 5)
423             return 1;
424         }
425     }
426
427   return (fast_string_match (XCHARSET_REGISTRY (charset),
428                              nonreloc, reloc, offset, length, 1,
429                              ERROR_ME, 0) >= 0);
430 }
431
432 /* find a font spec that matches font spec FONT and also matches
433    (the registry of) CHARSET. */
434 static Lisp_Object gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset);
435
436 #endif /* MULE */
437
438 \f
439 /************************************************************************/
440 /*                            initialization                            */
441 /************************************************************************/
442
443 void
444 syms_of_objects_gtk (void)
445 {
446 }
447
448 void
449 console_type_create_objects_gtk (void)
450 {
451   /* object methods */
452
453   CONSOLE_HAS_METHOD (gtk, initialize_color_instance);
454   CONSOLE_HAS_METHOD (gtk, print_color_instance);
455   CONSOLE_HAS_METHOD (gtk, finalize_color_instance);
456   CONSOLE_HAS_METHOD (gtk, color_instance_equal);
457   CONSOLE_HAS_METHOD (gtk, color_instance_hash);
458   CONSOLE_HAS_METHOD (gtk, color_instance_rgb_components);
459   CONSOLE_HAS_METHOD (gtk, valid_color_name_p);
460
461   CONSOLE_HAS_METHOD (gtk, initialize_font_instance);
462   CONSOLE_HAS_METHOD (gtk, mark_font_instance);
463   CONSOLE_HAS_METHOD (gtk, print_font_instance);
464   CONSOLE_HAS_METHOD (gtk, finalize_font_instance);
465   CONSOLE_HAS_METHOD (gtk, font_instance_truename);
466   CONSOLE_HAS_METHOD (gtk, font_instance_properties);
467   CONSOLE_HAS_METHOD (gtk, list_fonts);
468 #ifdef MULE
469   CONSOLE_HAS_METHOD (gtk, find_charset_font);
470   CONSOLE_HAS_METHOD (gtk, font_spec_matches_charset);
471 #endif
472 }
473
474 void
475 vars_of_objects_gtk (void)
476 {
477 }
478
479 /* #### BILL!!! Try to make this go away eventually */
480 /* X Specific stuff */
481 #include <X11/Xatom.h>
482
483 /* Unbounded, for sufficiently small values of infinity... */
484 #define MAX_FONT_COUNT INT_MAX
485
486 #ifdef MULE
487 /* find a font spec that matches font spec FONT and also matches
488    (the registry of) CHARSET. */
489 static Lisp_Object
490 gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
491 {
492   char **names;
493   int count = 0;
494   Lisp_Object result = Qnil;
495   const char *patternext;
496   int i;
497
498   TO_EXTERNAL_FORMAT (LISP_STRING, font, C_STRING_ALLOCA, patternext, Qbinary);
499
500   names = XListFonts (GDK_DISPLAY (),
501                       patternext, MAX_FONT_COUNT, &count);
502   /* ### This code seems awfully bogus -- mrb */
503   for (i = 0; i < count; i ++)
504     {
505       const Bufbyte *intname;
506       Bytecount intlen;
507
508       TO_INTERNAL_FORMAT (C_STRING, names[i], ALLOCA, (intname, intlen),
509                           Qctext);
510       if (gtk_font_spec_matches_charset (XDEVICE (device), charset,
511                                          intname, Qnil, 0, -1))
512         {
513           result = make_string ((char *) intname, intlen);
514           break;
515         }
516     }
517
518   if (names)
519     XFreeFontNames (names);
520
521   /* Check for a short font name. */
522   if (NILP (result)
523       && gtk_font_spec_matches_charset (XDEVICE (device), charset, 0,
524                                         font, 0, -1))
525     return font;
526
527   return result;
528 }
529 #endif /* MULE */
530
531 /* Unbounded, for sufficiently small values of infinity... */
532 #define MAX_FONT_COUNT INT_MAX
533
534 static int
535 valid_font_name_p (Display *dpy, char *name)
536 {
537   /* Maybe this should be implemented by callign XLoadFont and trapping
538      the error.  That would be a lot of work, and wasteful as hell, but
539      might be more correct.
540    */
541   int nnames = 0;
542   char **names = 0;
543   if (! name)
544     return 0;
545   names = XListFonts (dpy, name, 1, &nnames);
546   if (names)
547     XFreeFontNames (names);
548   return (nnames != 0);
549 }
550
551 Lisp_Object
552 __get_gtk_font_truename (GdkFont *gdk_font, int expandp)
553 {
554   Display *dpy = GDK_FONT_XDISPLAY (gdk_font);
555   GSList *names = ((GdkFontPrivate *) gdk_font)->names;
556   Lisp_Object font_name = Qnil;
557
558   while (names)
559     {
560       if (names->data)
561         {
562           if (valid_font_name_p (dpy, names->data))
563             {
564               if (!expandp)
565                 {
566                   /* They want the wildcarded version */
567                   font_name = build_string (names->data);
568                 }
569               else
570                 {
571                   /* Need to expand out */
572                   int nnames = 0;
573                   char **x_font_names = 0;
574
575                   x_font_names = XListFonts (dpy, names->data, 1, &nnames);
576                   if (x_font_names)
577                     {
578                       font_name = build_string (x_font_names[0]);
579                       XFreeFontNames (x_font_names);
580                     }
581                 }
582               break;
583             }
584         }
585       names = names->next;
586     }
587   return (font_name);
588 }
589
590 static Lisp_Object __gtk_list_fonts_internal (const char *pattern)
591 {
592   char **names;
593   int count = 0;
594   Lisp_Object result = Qnil;
595
596   names = XListFonts (GDK_DISPLAY (), pattern, MAX_FONT_COUNT, &count);
597   while (count--)
598     result = Fcons (build_ext_string (names [count], Qbinary), result);
599   if (names)
600     XFreeFontNames (names);
601
602   return result;
603 }