462
+ − 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.
872
+ − 5 Copyright (C) 1995, 1996, 2002 Ben Wing.
462
+ − 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
872
+ − 33 #include "buffer.h"
3676
+ − 34 #include "charset.h"
872
+ − 35 #include "device-impl.h"
+ − 36 #include "insdel.h"
462
+ − 37
872
+ − 38 #include "console-gtk-impl.h"
+ − 39 #include "objects-gtk-impl.h"
462
+ − 40
+ − 41 /* sigh */
+ − 42 #include <gdk/gdkx.h>
+ − 43
3659
+ − 44 /* XListFonts doesn't allocate memory unconditionally based on this. (For
+ − 45 XFree86 in 2005, at least. */
+ − 46 #define MAX_FONT_COUNT INT_MAX
+ − 47
+ − 48 #ifdef DEBUG_XEMACS
+ − 49 Fixnum debug_x_objects;
+ − 50 #endif /* DEBUG_XEMACS */
+ − 51
462
+ − 52
+ − 53 /************************************************************************/
+ − 54 /* color instances */
+ − 55 /************************************************************************/
+ − 56
+ − 57 /* Replacement for XAllocColor() that tries to return the nearest
+ − 58 available color if the colormap is full. Original was from FSFmacs,
+ − 59 but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25
+ − 60 Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous
+ − 61 total failure which was due to a read/write colorcell being the nearest
+ − 62 match - tries the next nearest...
+ − 63
+ − 64 Gdk takes care of all this behind the scenes, so we don't need to
+ − 65 worry about it.
+ − 66
+ − 67 Return value is 1 for normal success, 2 for nearest color success,
+ − 68 3 for Non-deallocable sucess. */
+ − 69 int
2286
+ − 70 allocate_nearest_color (GdkColormap *colormap, GdkVisual *UNUSED (visual),
462
+ − 71 GdkColor *color_def)
+ − 72 {
+ − 73 int rc;
+ − 74
+ − 75 rc = gdk_colormap_alloc_color (colormap, color_def, FALSE, TRUE);
+ − 76
+ − 77 if (rc == TRUE)
+ − 78 return (1);
+ − 79
+ − 80 return (0);
+ − 81 }
+ − 82
+ − 83 int
867
+ − 84 gtk_parse_nearest_color (struct device *d, GdkColor *color, Ibyte *name,
578
+ − 85 Bytecount len, Error_Behavior errb)
462
+ − 86 {
+ − 87 GdkColormap *cmap;
+ − 88 GdkVisual *visual;
+ − 89 int result;
+ − 90
+ − 91 cmap = DEVICE_GTK_COLORMAP(d);
+ − 92 visual = DEVICE_GTK_VISUAL (d);
+ − 93
+ − 94 xzero (*color);
+ − 95 {
+ − 96 const Extbyte *extname;
665
+ − 97 Bytecount extnamelen;
462
+ − 98
+ − 99 TO_EXTERNAL_FORMAT (DATA, (name, len), ALLOCA, (extname, extnamelen), Qbinary);
+ − 100
+ − 101 result = gdk_color_parse (extname, color);
+ − 102 }
+ − 103
+ − 104 if (result == FALSE)
+ − 105 {
563
+ − 106 maybe_invalid_argument ("unrecognized color", make_string (name, len),
+ − 107 Qcolor, errb);
462
+ − 108 return 0;
+ − 109 }
+ − 110 result = allocate_nearest_color (cmap, visual, color);
+ − 111 if (!result)
+ − 112 {
563
+ − 113 maybe_signal_error (Qgui_error, "couldn't allocate color",
+ − 114 make_string (name, len), Qcolor, errb);
462
+ − 115 return 0;
+ − 116 }
+ − 117
+ − 118 return result;
+ − 119 }
+ − 120
+ − 121 static int
+ − 122 gtk_initialize_color_instance (struct Lisp_Color_Instance *c, Lisp_Object name,
578
+ − 123 Lisp_Object device, Error_Behavior errb)
462
+ − 124 {
+ − 125 GdkColor color;
+ − 126 int result;
+ − 127
+ − 128 result = gtk_parse_nearest_color (XDEVICE (device), &color,
+ − 129 XSTRING_DATA (name),
+ − 130 XSTRING_LENGTH (name),
+ − 131 errb);
+ − 132
+ − 133 if (!result)
+ − 134 return 0;
+ − 135
+ − 136 /* Don't allocate the data until we're sure that we will succeed,
+ − 137 or the finalize method may get fucked. */
+ − 138 c->data = xnew (struct gtk_color_instance_data);
+ − 139 if (result == 3)
+ − 140 COLOR_INSTANCE_GTK_DEALLOC (c) = 0;
+ − 141 else
+ − 142 COLOR_INSTANCE_GTK_DEALLOC (c) = 1;
+ − 143 COLOR_INSTANCE_GTK_COLOR (c) = gdk_color_copy (&color);
+ − 144 return 1;
+ − 145 }
+ − 146
+ − 147 static void
+ − 148 gtk_print_color_instance (struct Lisp_Color_Instance *c,
+ − 149 Lisp_Object printcharfun,
2286
+ − 150 int UNUSED (escapeflag))
462
+ − 151 {
+ − 152 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
800
+ − 153 write_fmt_string (printcharfun, " %ld=(%X,%X,%X)",
+ − 154 color->pixel, color->red, color->green, color->blue);
462
+ − 155 }
+ − 156
+ − 157 static void
+ − 158 gtk_finalize_color_instance (struct Lisp_Color_Instance *c)
+ − 159 {
+ − 160 if (c->data)
+ − 161 {
+ − 162 if (DEVICE_LIVE_P (XDEVICE (c->device)))
+ − 163 {
+ − 164 if (COLOR_INSTANCE_GTK_DEALLOC (c))
+ − 165 {
+ − 166 gdk_colormap_free_colors (DEVICE_GTK_COLORMAP (XDEVICE (c->device)),
+ − 167 COLOR_INSTANCE_GTK_COLOR (c), 1);
+ − 168 }
+ − 169 gdk_color_free (COLOR_INSTANCE_GTK_COLOR (c));
+ − 170 }
1726
+ − 171 xfree (c->data, void *);
462
+ − 172 c->data = 0;
+ − 173 }
+ − 174 }
+ − 175
+ − 176 /* Color instances are equal if they resolve to the same color on the
+ − 177 screen (have the same RGB values). I imagine that
+ − 178 "same RGB values" == "same cell in the colormap." Arguably we should
+ − 179 be comparing their names or pixel values instead. */
+ − 180
+ − 181 static int
+ − 182 gtk_color_instance_equal (struct Lisp_Color_Instance *c1,
+ − 183 struct Lisp_Color_Instance *c2,
2286
+ − 184 int UNUSED (depth))
462
+ − 185 {
+ − 186 return (gdk_color_equal (COLOR_INSTANCE_GTK_COLOR (c1),
+ − 187 COLOR_INSTANCE_GTK_COLOR (c2)));
+ − 188 }
+ − 189
2515
+ − 190 static Hashcode
2286
+ − 191 gtk_color_instance_hash (struct Lisp_Color_Instance *c, int UNUSED (depth))
462
+ − 192 {
+ − 193 return (gdk_color_hash (COLOR_INSTANCE_GTK_COLOR (c), NULL));
+ − 194 }
+ − 195
+ − 196 static Lisp_Object
+ − 197 gtk_color_instance_rgb_components (struct Lisp_Color_Instance *c)
+ − 198 {
+ − 199 GdkColor *color = COLOR_INSTANCE_GTK_COLOR (c);
+ − 200 return (list3 (make_int (color->red),
+ − 201 make_int (color->green),
+ − 202 make_int (color->blue)));
+ − 203 }
+ − 204
+ − 205 static int
2286
+ − 206 gtk_valid_color_name_p (struct device *UNUSED (d), Lisp_Object color)
462
+ − 207 {
+ − 208 GdkColor c;
+ − 209 const char *extname;
+ − 210
+ − 211 TO_EXTERNAL_FORMAT (LISP_STRING, color, C_STRING_ALLOCA, extname, Qctext);
+ − 212
+ − 213 if (gdk_color_parse (extname, &c) != TRUE)
+ − 214 return(0);
+ − 215 return (1);
+ − 216 }
+ − 217
2527
+ − 218 static Lisp_Object
+ − 219 gtk_color_list (void)
+ − 220 {
+ − 221 /* #### BILL!!!
+ − 222 Is this correct? */
+ − 223 return call0 (intern ("x-color-list-internal"));
+ − 224 }
+ − 225
462
+ − 226
+ − 227 /************************************************************************/
+ − 228 /* font instances */
+ − 229 /************************************************************************/
+ − 230
+ − 231 static int
2286
+ − 232 gtk_initialize_font_instance (struct Lisp_Font_Instance *f,
+ − 233 Lisp_Object UNUSED (name),
+ − 234 Lisp_Object UNUSED (device), Error_Behavior errb)
462
+ − 235 {
+ − 236 GdkFont *gf;
+ − 237 XFontStruct *xf;
+ − 238 const char *extname;
+ − 239
+ − 240 TO_EXTERNAL_FORMAT (LISP_STRING, f->name, C_STRING_ALLOCA, extname, Qctext);
+ − 241
+ − 242 gf = gdk_font_load (extname);
+ − 243
+ − 244 if (!gf)
+ − 245 {
563
+ − 246 maybe_signal_error (Qgui_error, "couldn't load font", f->name,
+ − 247 Qfont, errb);
462
+ − 248 return 0;
+ − 249 }
+ − 250
2054
+ − 251 xf = (XFontStruct*) GDK_FONT_XFONT (gf);
462
+ − 252
+ − 253 /* Don't allocate the data until we're sure that we will succeed,
+ − 254 or the finalize method may get fucked. */
+ − 255 f->data = xnew (struct gtk_font_instance_data);
+ − 256 FONT_INSTANCE_GTK_FONT (f) = gf;
+ − 257 f->ascent = gf->ascent;
+ − 258 f->descent = gf->descent;
+ − 259 f->height = gf->ascent + gf->descent;
+ − 260
+ − 261 /* Now lets figure out the width of the font */
+ − 262 {
+ − 263 /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */
+ − 264 unsigned int def_char = 'n'; /*xf->default_char;*/
+ − 265 unsigned int byte1, byte2;
+ − 266
+ − 267 once_more:
+ − 268 byte1 = def_char >> 8;
+ − 269 byte2 = def_char & 0xFF;
+ − 270
+ − 271 if (xf->per_char)
+ − 272 {
+ − 273 /* Old versions of the R5 font server have garbage (>63k) as
+ − 274 def_char. 'n' might not be a valid character. */
+ − 275 if (byte1 < xf->min_byte1 ||
+ − 276 byte1 > xf->max_byte1 ||
+ − 277 byte2 < xf->min_char_or_byte2 ||
+ − 278 byte2 > xf->max_char_or_byte2)
+ − 279 f->width = 0;
+ − 280 else
+ − 281 f->width = xf->per_char[(byte1 - xf->min_byte1) *
+ − 282 (xf->max_char_or_byte2 -
+ − 283 xf->min_char_or_byte2 + 1) +
+ − 284 (byte2 - xf->min_char_or_byte2)].width;
+ − 285 }
+ − 286 else
+ − 287 f->width = xf->max_bounds.width;
+ − 288
+ − 289 /* Some fonts have a default char whose width is 0. This is no good.
+ − 290 If that's the case, first try 'n' as the default char, and if n has
+ − 291 0 width too (unlikely) then just use the max width. */
+ − 292 if (f->width == 0)
+ − 293 {
+ − 294 if (def_char == xf->default_char)
+ − 295 f->width = xf->max_bounds.width;
+ − 296 else
+ − 297 {
+ − 298 def_char = xf->default_char;
+ − 299 goto once_more;
+ − 300 }
+ − 301 }
+ − 302 }
+ − 303
+ − 304 /* If all characters don't exist then there could potentially be
+ − 305 0-width characters lurking out there. Not setting this flag
+ − 306 trips an optimization that would make them appear to have width
+ − 307 to redisplay. This is bad. So we set it if not all characters
+ − 308 have the same width or if not all characters are defined.
+ − 309 */
+ − 310 /* #### This sucks. There is a measurable performance increase
+ − 311 when using proportional width fonts if this flag is not set.
+ − 312 Unfortunately so many of the fucking X fonts are not fully
+ − 313 defined that we could almost just get rid of this damn flag and
+ − 314 make it an assertion. */
+ − 315 f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width ||
+ − 316 (/* x_handle_non_fully_specified_fonts */ 0 &&
+ − 317 !xf->all_chars_exist));
+ − 318 #if 0
+ − 319 f->width = gdk_char_width (gf, 'n');
+ − 320 f->proportional_p = (gdk_char_width (gf, '|') != gdk_char_width (gf, 'W')) ? 1 : 0;
+ − 321 #endif
+ − 322 return 1;
+ − 323 }
+ − 324
+ − 325 static void
+ − 326 gtk_print_font_instance (struct Lisp_Font_Instance *f,
+ − 327 Lisp_Object printcharfun,
2286
+ − 328 int UNUSED (escapeflag))
462
+ − 329 {
800
+ − 330 write_fmt_string (printcharfun, " 0x%lx",
+ − 331 (unsigned long) gdk_font_id (FONT_INSTANCE_GTK_FONT (f)));
462
+ − 332 }
+ − 333
+ − 334 static void
+ − 335 gtk_finalize_font_instance (struct Lisp_Font_Instance *f)
+ − 336 {
+ − 337 if (f->data)
+ − 338 {
+ − 339 if (DEVICE_LIVE_P (XDEVICE (f->device)))
+ − 340 {
+ − 341 gdk_font_unref (FONT_INSTANCE_GTK_FONT (f));
+ − 342 }
1726
+ − 343 xfree (f->data, void *);
462
+ − 344 f->data = 0;
+ − 345 }
+ − 346 }
+ − 347
+ − 348 /* Forward declarations for X specific functions at the end of the file */
+ − 349 Lisp_Object __get_gtk_font_truename (GdkFont *gdk_font, int expandp);
2527
+ − 350 static Lisp_Object __gtk_font_list_internal (const char *pattern);
462
+ − 351
+ − 352 static Lisp_Object
2286
+ − 353 gtk_font_instance_truename (struct Lisp_Font_Instance *f,
+ − 354 Error_Behavior UNUSED (errb))
462
+ − 355 {
872
+ − 356 if (NILP (FONT_INSTANCE_TRUENAME (f)))
462
+ − 357 {
872
+ − 358 FONT_INSTANCE_TRUENAME (f) = __get_gtk_font_truename (FONT_INSTANCE_GTK_FONT (f), 1);
462
+ − 359
872
+ − 360 if (NILP (FONT_INSTANCE_TRUENAME (f)))
462
+ − 361 {
+ − 362 /* Ok, just this once, return the font name as the truename.
+ − 363 (This is only used by Fequal() right now.) */
+ − 364 return f->name;
+ − 365 }
+ − 366 }
872
+ − 367 return (FONT_INSTANCE_TRUENAME (f));
462
+ − 368 }
+ − 369
+ − 370 static Lisp_Object
2286
+ − 371 gtk_font_instance_properties (struct Lisp_Font_Instance *UNUSED (f))
462
+ − 372 {
+ − 373 Lisp_Object result = Qnil;
+ − 374
+ − 375 /* #### BILL!!! */
+ − 376 /* There seems to be no way to get this information under Gtk */
+ − 377 return result;
+ − 378 }
+ − 379
+ − 380 static Lisp_Object
2527
+ − 381 gtk_font_list (Lisp_Object pattern, Lisp_Object UNUSED (device),
2286
+ − 382 Lisp_Object UNUSED (maxnumber))
462
+ − 383 {
+ − 384 const char *patternext;
+ − 385
+ − 386 TO_EXTERNAL_FORMAT (LISP_STRING, pattern, C_STRING_ALLOCA, patternext, Qbinary);
+ − 387
2527
+ − 388 return (__gtk_font_list_internal (patternext));
462
+ − 389 }
+ − 390
3659
+ − 391 /* Include the charset support, shared, for the moment, with X11. */
+ − 392 #define THIS_IS_GTK
+ − 393 #include "objects-xlike-inc.c"
462
+ − 394
+ − 395
+ − 396 /************************************************************************/
+ − 397 /* initialization */
+ − 398 /************************************************************************/
+ − 399
+ − 400 void
+ − 401 syms_of_objects_gtk (void)
+ − 402 {
+ − 403 }
+ − 404
+ − 405 void
+ − 406 console_type_create_objects_gtk (void)
+ − 407 {
+ − 408 /* object methods */
+ − 409
+ − 410 CONSOLE_HAS_METHOD (gtk, initialize_color_instance);
+ − 411 CONSOLE_HAS_METHOD (gtk, print_color_instance);
+ − 412 CONSOLE_HAS_METHOD (gtk, finalize_color_instance);
+ − 413 CONSOLE_HAS_METHOD (gtk, color_instance_equal);
+ − 414 CONSOLE_HAS_METHOD (gtk, color_instance_hash);
+ − 415 CONSOLE_HAS_METHOD (gtk, color_instance_rgb_components);
+ − 416 CONSOLE_HAS_METHOD (gtk, valid_color_name_p);
2527
+ − 417 CONSOLE_HAS_METHOD (gtk, color_list);
462
+ − 418
+ − 419 CONSOLE_HAS_METHOD (gtk, initialize_font_instance);
+ − 420 CONSOLE_HAS_METHOD (gtk, print_font_instance);
+ − 421 CONSOLE_HAS_METHOD (gtk, finalize_font_instance);
+ − 422 CONSOLE_HAS_METHOD (gtk, font_instance_truename);
+ − 423 CONSOLE_HAS_METHOD (gtk, font_instance_properties);
2527
+ − 424 CONSOLE_HAS_METHOD (gtk, font_list);
462
+ − 425 #ifdef MULE
+ − 426 CONSOLE_HAS_METHOD (gtk, find_charset_font);
+ − 427 CONSOLE_HAS_METHOD (gtk, font_spec_matches_charset);
+ − 428 #endif
+ − 429 }
+ − 430
+ − 431 void
+ − 432 vars_of_objects_gtk (void)
+ − 433 {
3659
+ − 434 #ifdef DEBUG_XEMACS
+ − 435 DEFVAR_INT ("debug-x-objects", &debug_x_objects /*
+ − 436 If non-zero, display debug information about X objects
+ − 437 */ );
+ − 438 debug_x_objects = 0;
+ − 439 #endif
462
+ − 440 }
+ − 441
+ − 442 static int
+ − 443 valid_font_name_p (Display *dpy, char *name)
+ − 444 {
+ − 445 /* Maybe this should be implemented by callign XLoadFont and trapping
+ − 446 the error. That would be a lot of work, and wasteful as hell, but
+ − 447 might be more correct.
+ − 448 */
+ − 449 int nnames = 0;
+ − 450 char **names = 0;
+ − 451 if (! name)
+ − 452 return 0;
+ − 453 names = XListFonts (dpy, name, 1, &nnames);
+ − 454 if (names)
+ − 455 XFreeFontNames (names);
+ − 456 return (nnames != 0);
+ − 457 }
+ − 458
+ − 459 Lisp_Object
+ − 460 __get_gtk_font_truename (GdkFont *gdk_font, int expandp)
+ − 461 {
+ − 462 Display *dpy = GDK_FONT_XDISPLAY (gdk_font);
+ − 463 GSList *names = ((GdkFontPrivate *) gdk_font)->names;
+ − 464 Lisp_Object font_name = Qnil;
+ − 465
+ − 466 while (names)
+ − 467 {
+ − 468 if (names->data)
+ − 469 {
2054
+ − 470 if (valid_font_name_p (dpy, (char*) names->data))
462
+ − 471 {
+ − 472 if (!expandp)
+ − 473 {
+ − 474 /* They want the wildcarded version */
2054
+ − 475 font_name = build_string ((char*) names->data);
462
+ − 476 }
+ − 477 else
+ − 478 {
+ − 479 /* Need to expand out */
+ − 480 int nnames = 0;
+ − 481 char **x_font_names = 0;
+ − 482
2054
+ − 483 x_font_names = XListFonts (dpy, (char*) names->data, 1, &nnames);
462
+ − 484 if (x_font_names)
+ − 485 {
+ − 486 font_name = build_string (x_font_names[0]);
+ − 487 XFreeFontNames (x_font_names);
+ − 488 }
+ − 489 }
+ − 490 break;
+ − 491 }
+ − 492 }
+ − 493 names = names->next;
+ − 494 }
+ − 495 return (font_name);
+ − 496 }
+ − 497
2527
+ − 498 static Lisp_Object __gtk_font_list_internal (const char *pattern)
462
+ − 499 {
+ − 500 char **names;
+ − 501 int count = 0;
+ − 502 Lisp_Object result = Qnil;
+ − 503
+ − 504 names = XListFonts (GDK_DISPLAY (), pattern, MAX_FONT_COUNT, &count);
+ − 505 while (count--)
+ − 506 result = Fcons (build_ext_string (names [count], Qbinary), result);
+ − 507 if (names)
+ − 508 XFreeFontNames (names);
+ − 509
+ − 510 return result;
+ − 511 }