Mercurial > hg > xemacs-beta

comparison src/objects-xlike-inc.c @ 2586:196ee3cd1ac5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-02-15 01:19:48 by ben] first check-in of ben-fixup branch
author ben
date Tue, 15 Feb 2005 01:21:24 +0000
parents
children
comparison
equal deleted inserted replaced
2585:a81fa696baa5 2586:196ee3cd1ac5
1 /* Include file for common code, X and GTK colors and fonts.
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, 2001, 2002, 2003, 2004, 2005 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 /* Extracted from objects-x.c, objects-gtk.c 2-13-05.
30 NOTE: There is an advantage to having the code coalesced this way
31 even when there is a fair amount of difference between the two versions,
32 provided that they are still parallel -- having them side by side ensures
33 that logic changes in one are propagated to the other, preventing bit-rot
34 --ben
35 */
36
37 #ifndef THIS_IS_GTK
38 #define ZZCOLOR_TYPE XColor
39 #define ZZCOLOR_INSTANCE(name) COLOR_INSTANCE_X_##name
40 #define ZZ(z) x_##z
41 #define ZZEND(z) z##_x
42 #define ZZCONSOLE_HAS_METHOD(name) CONSOLE_HAS_METHOD (x, name)
43 #define UNUSED_IF_GTK(arg) arg
44 #else
45 #define ZZCOLOR_TYPE GdkColor
46 #define ZZCOLOR_INSTANCE(name) COLOR_INSTANCE_GTK_##name
47 #define ZZ(z) gtk_##z
48 #define ZZEND(z) z##_gtk
49 #define ZZCONSOLE_HAS_METHOD(name) CONSOLE_HAS_METHOD (gtk, name)
50 #define UNUSED_IF_GTK(arg) UNUSED (arg)
51 #endif
52
53
54 /************************************************************************/
55 /* color instances */
56 /************************************************************************/
57
58 static int
59 ZZ (parse_nearest_color) (struct device *d, ZZCOLOR_TYPE *color,
60 Lisp_Object name, Error_Behavior errb)
61 {
62 #ifndef THIS_IS_GTK
63 Display *dpy = DEVICE_X_DISPLAY (d);
64 Colormap cmap = DEVICE_X_COLORMAP (d);
65 Visual *visual = DEVICE_X_VISUAL (d);
66 #else /* THIS_IS_GTK */
67 GdkColormap *cmap = DEVICE_GTK_COLORMAP (d);
68 GdkVisual *visual = DEVICE_GTK_VISUAL (d);
69 #endif /* THIS_IS_GTK */
70 int result;
71
72 xzero (*color);
73
74 #ifndef THIS_IS_GTK
75 result =
76 XParseColor (dpy, cmap,
77 NEW_LISP_STRING_TO_EXTERNAL (name, Qx_color_name_encoding),
78 color);
79 #else /* THIS_IS_GTK */
80 result = gdk_color_parse (LISP_STRING_TO_GTK_TEXT (name), color);
81 #endif /* THIS_IS_GTK */
82 if (!result)
83 {
84 maybe_signal_error (Qgui_error, "Unrecognized color",
85 name, Qcolor, errb);
86 return 0;
87 }
88 #ifndef THIS_IS_GTK
89 result = ZZ (allocate_nearest_color) (dpy, cmap, visual, color);
90 #else /* THIS_IS_GTK */
91 result = ZZ (allocate_nearest_color) (cmap, visual, color);
92 #endif /* THIS_IS_GTK */
93 if (!result)
94 {
95 maybe_signal_error (Qgui_error, "Couldn't allocate color",
96 name, Qcolor, errb);
97 return 0;
98 }
99
100 return result;
101 }
102
103 static int
104 ZZ (initialize_color_instance) (Lisp_Color_Instance *c, Lisp_Object name,
105 Lisp_Object device, Error_Behavior errb)
106 {
107 ZZCOLOR_TYPE color;
108 int result;
109
110 result = ZZ (parse_nearest_color) (XDEVICE (device), &color, name, errb);
111
112 if (!result)
113 return 0;
114
115 /* Don't allocate the data until we're sure that we will succeed,
116 or the finalize method may get fucked. */
117 c->data = xnew (struct ZZ (color_instance_data));
118 if (result == 3)
119 ZZCOLOR_INSTANCE (DEALLOC) (c) = 0;
120 else
121 ZZCOLOR_INSTANCE (DEALLOC) (c) = 1;
122 #ifndef THIS_IS_GTK
123 ZZCOLOR_INSTANCE (COLOR) (c) = color;
124 #else /* THIS_IS_GTK */
125 ZZCOLOR_INSTANCE (COLOR) (c) = gdk_color_copy (&color);
126 #endif /* THIS_IS_GTK */
127 return 1;
128 }
129
130 static void
131 ZZ (print_color_instance) (Lisp_Color_Instance *c,
132 Lisp_Object printcharfun,
133 int UNUSED (escapeflag))
134 {
135 #ifndef THIS_IS_GTK
136 XColor color = COLOR_INSTANCE_X_COLOR (c);
137 write_fmt_string (printcharfun, " %ld=(%X,%X,%X)",
138 color.pixel, color.red, color.green, color.blue);
139 #else /* THIS_IS_GTK */
140 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
141 write_fmt_string (printcharfun, " %ld=(%X,%X,%X)",
142 color->pixel, color->red, color->green, color->blue);
143 #endif /* THIS_IS_GTK */
144 }
145
146 static void
147 ZZ (finalize_color_instance) (Lisp_Color_Instance *c)
148 {
149 if (c->data)
150 {
151 if (DEVICE_LIVE_P (XDEVICE (c->device)))
152 {
153 if (ZZCOLOR_INSTANCE (DEALLOC) (c))
154 {
155 #ifndef THIS_IS_GTK
156 XFreeColors (DEVICE_X_DISPLAY (XDEVICE (c->device)),
157 DEVICE_X_COLORMAP (XDEVICE (c->device)),
158 &COLOR_INSTANCE_X_COLOR (c).pixel, 1, 0);
159 #else /* THIS_IS_GTK */
160 gdk_colormap_free_colors (DEVICE_GTK_COLORMAP
161 (XDEVICE (c->device)),
162 COLOR_INSTANCE_GTK_COLOR (c), 1);
163 #endif /* THIS_IS_GTK */
164 }
165 #ifdef THIS_IS_GTK
166 gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c));
167 #endif /* THIS_IS_GTK */
168 }
169 xfree (c->data, void *);
170 c->data = 0;
171 }
172 }
173
174 /* Color instances are equal if they resolve to the same color on the
175 screen (have the same RGB values). I imagine that
176 "same RGB values" == "same cell in the colormap." Arguably we should
177 be comparing their names or pixel values instead. */
178
179 static int
180 ZZ (color_instance_equal) (Lisp_Color_Instance *c1,
181 Lisp_Color_Instance *c2,
182 int UNUSED (depth))
183 {
184 #ifndef THIS_IS_GTK
185 XColor color1 = COLOR_INSTANCE_X_COLOR (c1);
186 XColor color2 = COLOR_INSTANCE_X_COLOR (c2);
187 return ((color1.red == color2.red) &&
188 (color1.green == color2.green) &&
189 (color1.blue == color2.blue));
190 #else /* THIS_IS_GTK */
191 return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1),
192 COLOR_INSTANCE_GTK_COLOR (c2)));
193 #endif /* THIS_IS_GTK */
194 }
195
196 static Hashcode
197 ZZ (color_instance_hash) (Lisp_Color_Instance *c, int UNUSED (depth))
198 {
199 #ifndef THIS_IS_GTK
200 XColor color = COLOR_INSTANCE_X_COLOR (c);
201 return HASH3 (color.red, color.green, color.blue);
202 #else /* THIS_IS_GTK */
203 return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL));
204 #endif /* THIS_IS_GTK */
205 }
206
207 static Lisp_Object
208 ZZ (color_instance_rgb_components) (Lisp_Color_Instance *c)
209 {
210 #ifndef THIS_IS_GTK
211 XColor color = COLOR_INSTANCE_X_COLOR (c);
212 return (list3 (make_int (color.red),
213 make_int (color.green),
214 make_int (color.blue)));
215 #else /* THIS_IS_GTK */
216 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
217 return (list3 (make_int (color->red),
218 make_int (color->green),
219 make_int (color->blue)));
220 #endif /* THIS_IS_GTK */
221 }
222
223 static int
224 ZZ (valid_color_name_p) (struct device *UNUSED_IF_GTK (d), Lisp_Object color)
225 {
226 #ifndef THIS_IS_GTK
227 XColor c;
228 Display *dpy = DEVICE_X_DISPLAY (d);
229 Colormap cmap = DEVICE_X_COLORMAP (d);
230 const Extbyte *extname;
231
232 LISP_STRING_TO_EXTERNAL (color, extname, Qx_color_name_encoding);
233
234 return XParseColor (dpy, cmap, extname, &c);
235 #else /* THIS_IS_GTK */
236 GdkColor c;
237 const Extbyte *extname;
238
239 LISP_STRING_TO_EXTERNAL (color, extname, Vgtk_text_encoding);
240
241 if (gdk_color_parse (extname, &c) != TRUE)
242 return 0;
243 return 1;
244 #endif /* THIS_IS_GTK */
245 }
246
247 static Lisp_Object
248 ZZ (color_list) (void)
249 {
250 #ifdef THIS_IS_GTK
251 /* #### BILL!!!
252 Is this correct? */
253 #endif /* THIS_IS_GTK */
254 return call0 (intern ("x-color-list-internal"));
255 }
256
257
258 /************************************************************************/
259 /* font instances */
260 /************************************************************************/
261
262 static int
263 ZZ (initialize_font_instance) (Lisp_Font_Instance *f,
264 Lisp_Object UNUSED (name),
265 Lisp_Object UNUSED_IF_GTK (device),
266 Error_Behavior errb)
267 {
268 XFontStruct *xf;
269 const Extbyte *extname;
270
271 #ifndef THIS_IS_GTK
272 Display *dpy = DEVICE_X_DISPLAY (XDEVICE (device));
273
274 LISP_STRING_TO_EXTERNAL (f->name, extname, Qx_font_name_encoding);
275 xf = XLoadQueryFont (dpy, extname);
276
277 if (!xf)
278 {
279 maybe_signal_error (Qgui_error, "Couldn't load font", f->name,
280 Qfont, errb);
281 return 0;
282 }
283
284 if (!xf->max_bounds.width)
285 {
286 /* yes, this has been known to happen. */
287 XFreeFont (dpy, xf);
288 maybe_signal_error (Qgui_error, "X font is too small", f->name, Qfont,
289 errb);
290
291 return 0;
292 }
293
294 #else /* THIS_IS_GTK */
295 GdkFont *gf;
296
297 LISP_STRING_TO_EXTERNAL (f->name, extname, Vgtk_text_encoding);
298 gf = gdk_font_load (extname);
299
300 if (!gf)
301 {
302 maybe_signal_error (Qgui_error, "Couldn't load font", f->name,
303 Qfont, errb);
304 return 0;
305 }
306
307 xf = (XFontStruct *) GDK_FONT_XFONT (gf);
308
309 #endif /* THIS_IS_GTK */
310
311 /* Don't allocate the data until we're sure that we will succeed,
312 or the finalize method may get fucked. */
313
314 #ifndef THIS_IS_GTK
315 f->data = xnew (struct x_font_instance_data);
316 FONT_INSTANCE_X_FONT (f) = xf;
317 f->ascent = xf->ascent;
318 f->descent = xf->descent;
319 f->height = xf->ascent + xf->descent;
320 #else /* THIS_IS_GTK */
321 f->data = xnew (struct gtk_font_instance_data);
322 FONT_INSTANCE_GTK_FONT (f) = gf;
323 f->ascent = gf->ascent;
324 f->descent = gf->descent;
325 f->height = gf->ascent + gf->descent;
326 #endif /* THIS_IS_GTK */
327
328 /* Now let's figure out the width of the font */
329
330 {
331 /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */
332 int def_char = 'n'; /*xf->default_char;*/
333 int byte1, byte2;
334
335 once_more:
336 byte1 = def_char >> 8;
337 byte2 = def_char & 0xFF;
338
339 if (xf->per_char)
340 {
341 /* Old versions of the R5 font server have garbage (>63k) as
342 def_char. 'n' might not be a valid character. */
343 if (byte1 < (int) xf->min_byte1 ||
344 byte1 > (int) xf->max_byte1 ||
345 byte2 < (int) xf->min_char_or_byte2 ||
346 byte2 > (int) xf->max_char_or_byte2)
347 f->width = 0;
348 else
349 f->width = xf->per_char[(byte1 - xf->min_byte1) *
350 (xf->max_char_or_byte2 -
351 xf->min_char_or_byte2 + 1) +
352 (byte2 - xf->min_char_or_byte2)].width;
353 }
354 else
355 f->width = xf->max_bounds.width;
356
357 /* Some fonts have a default char whose width is 0. This is no good.
358 If that's the case, first try 'n' as the default char, and if n has
359 0 width too (unlikely) then just use the max width. */
360 if (f->width == 0)
361 {
362 if (def_char == (int) xf->default_char)
363 f->width = xf->max_bounds.width;
364 else
365 {
366 def_char = xf->default_char;
367 goto once_more;
368 }
369 }
370 }
371 /* If all characters don't exist then there could potentially be
372 0-width characters lurking out there. Not setting this flag
373 trips an optimization that would make them appear to have width
374 to redisplay. This is bad. So we set it if not all characters
375 have the same width or if not all characters are defined.
376 */
377 /* #### This sucks. There is a measurable performance increase
378 when using proportional width fonts if this flag is not set.
379 Unfortunately so many of the fucking X fonts are not fully
380 defined that we could almost just get rid of this damn flag and
381 make it an assertion. */
382 f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width ||
383 (
384 #ifndef THIS_IS_GTK
385 x_handle_non_fully_specified_fonts &&
386 #else /* THIS_IS_GTK */
387 /* x_handle_non_fully_specified_fonts */ 0 &&
388 #endif /* THIS_IS_GTK */
389 !xf->all_chars_exist));
390
391 #if 0 /* THIS_IS_GTK */
392 f->width = gdk_char_width (gf, 'n');
393 f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W'));
394 #endif
395 return 1;
396 }
397
398 static void
399 ZZ (print_font_instance) (Lisp_Font_Instance *f,
400 Lisp_Object printcharfun,
401 int UNUSED (escapeflag))
402 {
403 write_fmt_string (printcharfun, " 0x%lx",
404 #ifndef THIS_IS_GTK
405 (unsigned long) FONT_INSTANCE_X_FONT (f)->fid);
406 #else /* THIS_IS_GTK */
407 (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f)));
408 #endif /* THIS_IS_GTK */
409 }
410
411 static void
412 ZZ (finalize_font_instance) (Lisp_Font_Instance *f)
413 {
414 if (f->data)
415 {
416 if (DEVICE_LIVE_P (XDEVICE (f->device)))
417 {
418 #ifndef THIS_IS_GTK
419 XFreeFont (DEVICE_X_DISPLAY (XDEVICE (f->device)),
420 FONT_INSTANCE_X_FONT (f));
421 #else /* THIS_IS_GTK */
422 gdk_font_unref (FONT_INSTANCE_GTK_FONT (f));
423 #endif /* THIS_IS_GTK */
424 }
425 xfree (f->data, void *);
426 f->data = 0;
427 }
428 }
429
430 /* Unbounded, for sufficiently small values of infinity... */
431 #define MAX_FONT_COUNT 5000
432
433 #ifndef THIS_IS_GTK
434 static Lisp_Object x_font_truename (Display *dpy, Extbyte *name,
435 XFontStruct *font);
436 #else
437 Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp);
438 #endif
439
440 static Lisp_Object
441 ZZ (font_instance_truename) (Lisp_Font_Instance *f, Error_Behavior errb)
442 {
443 if (NILP (FONT_INSTANCE_TRUENAME (f)))
444 {
445 #ifndef THIS_IS_GTK
446 FONT_INSTANCE_TRUENAME (f) =
447 x_font_truename (DEVICE_X_DISPLAY (XDEVICE (f->device)),
448 NEW_LISP_STRING_TO_EXTERNAL
449 (f->name, Qx_font_name_encoding),
450 FONT_INSTANCE_X_FONT (f));
451 #else
452 FONT_INSTANCE_TRUENAME (f) =
453 __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1);
454 #endif /* THIS_IS_GTK */
455
456 if (NILP (FONT_INSTANCE_TRUENAME (f)))
457 {
458 Lisp_Object font_instance = wrap_font_instance (f);
459
460
461 maybe_signal_error (Qgui_error, "Couldn't determine font truename",
462 font_instance, Qfont, errb);
463 /* Ok, just this once, return the font name as the truename.
464 (This is only used by Fequal() right now.) */
465 return f->name;
466 }
467 }
468 return FONT_INSTANCE_TRUENAME (f);
469 }
470
471 #ifdef MULE
472
473 static int
474 ZZ (font_spec_matches_charset) (struct device *UNUSED (d), Lisp_Object charset,
475 const Ibyte *nonreloc, Lisp_Object reloc,
476 Bytecount offset, Bytecount length,
477 int stage)
478 {
479 if (stage)
480 return 0;
481
482 if (UNBOUNDP (charset))
483 return 1;
484 /* Hack! Short font names don't have the registry in them,
485 so we just assume the user knows what they're doing in the
486 case of ASCII. For other charsets, you gotta give the
487 long form; sorry buster.
488 */
489 if (EQ (charset, Vcharset_ascii))
490 {
491 const Ibyte *the_nonreloc = nonreloc;
492 int i;
493 Bytecount the_length = length;
494
495 if (!the_nonreloc)
496 the_nonreloc = XSTRING_DATA (reloc);
497 fixup_internal_substring (nonreloc, reloc, offset, &the_length);
498 the_nonreloc += offset;
499 if (!memchr (the_nonreloc, '*', the_length))
500 {
501 for (i = 0;; i++)
502 {
503 const Ibyte *new_nonreloc = (const Ibyte *)
504 memchr (the_nonreloc, '-', the_length);
505 if (!new_nonreloc)
506 break;
507 new_nonreloc++;
508 the_length -= new_nonreloc - the_nonreloc;
509 the_nonreloc = new_nonreloc;
510 }
511
512 /* If it has less than 5 dashes, it's a short font.
513 Of course, long fonts always have 14 dashes or so, but short
514 fonts never have more than 1 or 2 dashes, so this is some
515 sort of reasonable heuristic. */
516 if (i < 5)
517 return 1;
518 }
519 }
520
521 return (fast_string_match (XCHARSET_REGISTRY (charset),
522 nonreloc, reloc, offset, length, 1,
523 ERROR_ME, 0) >= 0);
524 }
525
526 /* find a font spec that matches font spec FONT and also matches
527 (the registry of) CHARSET. */
528 static Lisp_Object
529 ZZ (find_charset_font) (Lisp_Object device, Lisp_Object font,
530 Lisp_Object charset, int stage)
531 {
532 #ifdef THIS_IS_GTK
533 /* #### copied from x_find_charset_font */
534 /* #### BILL!!! Try to make this go away eventually */
535 #endif /* THIS_IS_GTK */
536 Extbyte **names;
537 int count = 0;
538 Lisp_Object result = Qnil;
539 const Extbyte *patternext;
540 int i;
541
542 if (stage)
543 return Qnil;
544
545 LISP_STRING_TO_EXTERNAL (font, patternext, Qx_font_name_encoding);
546
547 names = XListFonts (
548 #ifndef THIS_IS_GTK
549 DEVICE_X_DISPLAY (XDEVICE (device)),
550 #else
551 GDK_DISPLAY (),
552 #endif
553 patternext, MAX_FONT_COUNT, &count);
554 /* #### This code seems awfully bogus -- mrb */
555 for (i = 0; i < count; i ++)
556 {
557 const Ibyte *intname;
558 Bytecount intlen;
559
560 EXTERNAL_TO_SIZED_C_STRING (names[i], intname, intlen,
561 Qx_font_name_encoding);
562 if (ZZ (font_spec_matches_charset) (XDEVICE (device), charset,
563 intname, Qnil, 0, -1, stage))
564 {
565 result = make_string (intname, intlen);
566 break;
567 }
568 }
569
570 if (names)
571 XFreeFontNames (names);
572
573 /* Check for a short font name. */
574 if (NILP (result)
575 && ZZ (font_spec_matches_charset) (XDEVICE (device), charset, 0,
576 font, 0, -1, stage))
577 return font;
578
579 return result;
580 }
581
582 #endif /* MULE */
583
584
585 /************************************************************************/
586 /* initialization */
587 /************************************************************************/
588
589 void
590 ZZEND (console_type_create_objects) (void)
591 {
592 /* object methods */
593
594 ZZCONSOLE_HAS_METHOD (initialize_color_instance);
595 ZZCONSOLE_HAS_METHOD (print_color_instance);
596 ZZCONSOLE_HAS_METHOD (finalize_color_instance);
597 ZZCONSOLE_HAS_METHOD (color_instance_equal);
598 ZZCONSOLE_HAS_METHOD (color_instance_hash);
599 ZZCONSOLE_HAS_METHOD (color_instance_rgb_components);
600 ZZCONSOLE_HAS_METHOD (valid_color_name_p);
601 ZZCONSOLE_HAS_METHOD (color_list);
602
603 ZZCONSOLE_HAS_METHOD (initialize_font_instance);
604 ZZCONSOLE_HAS_METHOD (print_font_instance);
605 ZZCONSOLE_HAS_METHOD (finalize_font_instance);
606 ZZCONSOLE_HAS_METHOD (font_instance_truename);
607 ZZCONSOLE_HAS_METHOD (font_instance_properties);
608 ZZCONSOLE_HAS_METHOD (font_list);
609 #ifdef MULE
610 ZZCONSOLE_HAS_METHOD (find_charset_font);
611 ZZCONSOLE_HAS_METHOD (font_spec_matches_charset);
612 #endif
613 }