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.
8 This file is part of XEmacs.
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
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
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. */
25 /* Synched up with: Not in FSF. */
27 /* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */
28 /* Gtk version by William Perry */
33 #include "console-gtk.h"
34 #include "objects-gtk.h"
44 /************************************************************************/
46 /************************************************************************/
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...
55 Gdk takes care of all this behind the scenes, so we don't need to
58 Return value is 1 for normal success, 2 for nearest color success,
59 3 for Non-deallocable sucess. */
61 allocate_nearest_color (GdkColormap *colormap, GdkVisual *visual,
66 rc = gdk_colormap_alloc_color (colormap, color_def, FALSE, TRUE);
75 gtk_parse_nearest_color (struct device *d, GdkColor *color, Bufbyte *name,
76 Bytecount len, Error_behavior errb)
82 cmap = DEVICE_GTK_COLORMAP(d);
83 visual = DEVICE_GTK_VISUAL (d);
87 const Extbyte *extname;
90 TO_EXTERNAL_FORMAT (DATA, (name, len), ALLOCA, (extname, extnamelen), Qbinary);
92 result = gdk_color_parse (extname, color);
97 maybe_signal_simple_error ("unrecognized color", make_string (name, len),
101 result = allocate_nearest_color (cmap, visual, color);
104 maybe_signal_simple_error ("couldn't allocate color",
105 make_string (name, len), Qcolor, errb);
113 gtk_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
114 Lisp_Object device, Error_behavior errb)
119 result = gtk_parse_nearest_color (XDEVICE (device), &color,
121 XSTRING_LENGTH (name),
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);
131 COLOR_INSTANCE_GTK_DEALLOC (c) = 0;
133 COLOR_INSTANCE_GTK_DEALLOC (c) = 1;
134 COLOR_INSTANCE_GTK_COLOR (c) = gdk_color_copy (&color);
139 gtk_print_color_instance (struct Lisp_Color_Instance *c,
140 Lisp_Object printcharfun,
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);
151 gtk_finalize_color_instance (struct Lisp_Color_Instance *c)
155 if (DEVICE_LIVE_P (XDEVICE (c->device)))
157 if (COLOR_INSTANCE_GTK_DEALLOC (c))
159 gdk_colormap_free_colors (DEVICE_GTK_COLORMAP (XDEVICE (c->device)),
160 COLOR_INSTANCE_GTK_COLOR (c), 1);
162 gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c));
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. */
175 gtk_color_instance_equal (struct Lisp_Color_Instance *c1,
176 struct Lisp_Color_Instance *c2,
179 return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1),
180 COLOR_INSTANCE_GTK_COLOR (c2)));
184 gtk_color_instance_hash (struct Lisp_Color_Instance *c, int depth)
186 return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL));
190 gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c)
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)));
199 gtk_valid_color_name_p (struct device *d, Lisp_Object color)
204 TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext);
206 if (gdk_color_parse (extname, &c) != TRUE)
212 /************************************************************************/
214 /************************************************************************/
217 gtk_initialize_font_instance (struct Lisp_Font_Instance *f, Lisp_Object name,
218 Lisp_Object device, Error_behavior errb)
224 TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext);
226 gf = gdk_font_load (extname);
230 maybe_signal_simple_error ("couldn't load font", f->name,
235 xf = GDK_FONT_XFONT (gf);
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;
246 /* Now lets figure out the width of the font */
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;
253 byte1 = def_char >> 8;
254 byte2 = def_char & 0xFF;
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)
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;
272 f->width = xf->max_bounds.width;
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. */
279 if (def_char == xf->default_char)
280 f->width = xf->max_bounds.width;
283 def_char = xf->default_char;
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.
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));
304 f->width = gdk_char_width (gf, 'n');
305 f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W')) ? 1 : 0;
311 gtk_mark_font_instance (struct Lisp_Font_Instance *f)
313 mark_object (FONT_INSTANCE_GTK_TRUENAME (f));
317 gtk_print_font_instance (struct Lisp_Font_Instance *f,
318 Lisp_Object printcharfun,
322 sprintf (buf, " 0x%lx", (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f)));
323 write_c_string (buf, printcharfun);
327 gtk_finalize_font_instance (struct Lisp_Font_Instance *f)
331 if (DEVICE_LIVE_P (XDEVICE (f->device)))
333 gdk_font_unref (FONT_INSTANCE_GTK_FONT (f));
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);
345 gtk_font_instance_truename (struct Lisp_Font_Instance *f, Error_behavior errb)
347 if (NILP (FONT_INSTANCE_GTK_TRUENAME (f)))
349 FONT_INSTANCE_GTK_TRUENAME (f) = __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1);
351 if (NILP (FONT_INSTANCE_GTK_TRUENAME (f)))
353 /* Ok, just this once, return the font name as the truename.
354 (This is only used by Fequal() right now.) */
358 return (FONT_INSTANCE_GTK_TRUENAME (f));
362 gtk_font_instance_properties (struct Lisp_Font_Instance *f)
364 Lisp_Object result = Qnil;
367 /* There seems to be no way to get this information under Gtk */
372 gtk_list_fonts (Lisp_Object pattern, Lisp_Object device)
374 const char *patternext;
376 TO_EXTERNAL_FORMAT (LISP_STRING, pattern, C_STRING_ALLOCA, patternext, Qbinary);
378 return (__gtk_list_fonts_internal (patternext));
384 gtk_font_spec_matches_charset (struct device *d, Lisp_Object charset,
385 const Bufbyte *nonreloc, Lisp_Object reloc,
386 Bytecount offset, Bytecount length)
388 if (UNBOUNDP (charset))
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.
395 if (EQ (charset, Vcharset_ascii))
397 const Bufbyte *the_nonreloc = nonreloc;
399 Bytecount the_length = length;
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))
409 const Bufbyte *new_nonreloc = (const Bufbyte *)
410 memchr (the_nonreloc, '-', the_length);
414 the_length -= new_nonreloc - the_nonreloc;
415 the_nonreloc = new_nonreloc;
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. */
427 return (fast_string_match (XCHARSET_REGISTRY (charset),
428 nonreloc, reloc, offset, length, 1,
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);
439 /************************************************************************/
441 /************************************************************************/
444 syms_of_objects_gtk (void)
449 console_type_create_objects_gtk (void)
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);
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);
469 CONSOLE_HAS_METHOD (gtk, find_charset_font);
470 CONSOLE_HAS_METHOD (gtk, font_spec_matches_charset);
475 vars_of_objects_gtk (void)
479 /* #### BILL!!! Try to make this go away eventually */
480 /* X Specific stuff */
481 #include <X11/Xatom.h>
483 /* Unbounded, for sufficiently small values of infinity... */
484 #define MAX_FONT_COUNT INT_MAX
487 /* find a font spec that matches font spec FONT and also matches
488 (the registry of) CHARSET. */
490 gtk_find_charset_font (Lisp_Object device, Lisp_Object font, Lisp_Object charset)
494 Lisp_Object result = Qnil;
495 const char *patternext;
498 TO_EXTERNAL_FORMAT (LISP_STRING, font, C_STRING_ALLOCA, patternext, Qbinary);
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 ++)
505 const Bufbyte *intname;
508 TO_INTERNAL_FORMAT (C_STRING, names[i], ALLOCA, (intname, intlen),
510 if (gtk_font_spec_matches_charset (XDEVICE (device), charset,
511 intname, Qnil, 0, -1))
513 result = make_string ((char *) intname, intlen);
519 XFreeFontNames (names);
521 /* Check for a short font name. */
523 && gtk_font_spec_matches_charset (XDEVICE (device), charset, 0,
531 /* Unbounded, for sufficiently small values of infinity... */
532 #define MAX_FONT_COUNT INT_MAX
535 valid_font_name_p (Display *dpy, char *name)
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.
545 names = XListFonts (dpy, name, 1, &nnames);
547 XFreeFontNames (names);
548 return (nnames != 0);
552 __get_gtk_font_truename (GdkFont *gdk_font, int expandp)
554 Display *dpy = GDK_FONT_XDISPLAY (gdk_font);
555 GSList *names = ((GdkFontPrivate *) gdk_font)->names;
556 Lisp_Object font_name = Qnil;
562 if (valid_font_name_p (dpy, names->data))
566 /* They want the wildcarded version */
567 font_name = build_string (names->data);
571 /* Need to expand out */
573 char **x_font_names = 0;
575 x_font_names = XListFonts (dpy, names->data, 1, &nnames);
578 font_name = build_string (x_font_names[0]);
579 XFreeFontNames (x_font_names);
590 static Lisp_Object __gtk_list_fonts_internal (const char *pattern)
594 Lisp_Object result = Qnil;
596 names = XListFonts (GDK_DISPLAY (), pattern, MAX_FONT_COUNT, &count);
598 result = Fcons (build_ext_string (names [count], Qbinary), result);
600 XFreeFontNames (names);