Mercurial > hg > xemacs-beta

comparison src/objects-gtk.c @ 462:0784d089fdc9 r21-2-46

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-46
author cvs
date Mon, 13 Aug 2007 11:44:37 +0200
parents
children 183866b06e0b
comparison
equal deleted inserted replaced
461:120ed4009e51 462:0784d089fdc9
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
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
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
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 5000
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 5000
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 }