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 }