cgit.sxemacs.org Git - sxemacs/blob - src/ui/Gtk/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 SXEmacs
   9
  10 SXEmacs is free software: you can redistribute it and/or modify
  11 it under the terms of the GNU General Public License as published by
  12 the Free Software Foundation, either version 3 of the License, or
  13 (at your option) any later version.
  14
  15 SXEmacs is distributed in the hope that it will be useful,
  16 but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 GNU General Public License for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  22
  23
  24 /* Synched up with: Not in FSF. */
  25
  26 /* Authors: Jamie Zawinski, Chuck Thompson, Ben Wing */
  27 /* Gtk version by William Perry */
  28
  29 #include <config.h>
  30 #include "lisp.h"
  31
  32 #include "console-gtk.h"
  33 #include "objects-gtk.h"
  34
  35 #include "buffer.h"
  36 #include "ui/device.h"
  37 #include "ui/insdel.h"
  38
  39 /* sigh */
  40 #include <gdk/gdkx.h>
  41 \f
  42 /************************************************************************/
  43 /*                          color instances                             */
  44 /************************************************************************/
  45
  46 /* Replacement for XAllocColor() that tries to return the nearest
  47    available color if the colormap is full.  Original was from FSFmacs,
  48    but rewritten by Jareth Hein <jareth@camelot-soft.com> 97/11/25
  49    Modified by Lee Kindness <lkindness@csl.co.uk> 31/08/99 to handle previous
  50    total failure which was due to a read/write colorcell being the nearest
  51    match - tries the next nearest...
  52
  53    Gdk takes care of all this behind the scenes, so we don't need to
  54    worry about it.
  55
  56    Return value is 1 for normal success, 2 for nearest color success,
  57    3 for Non-deallocable sucess. */
  58 int
  59 allocate_nearest_color(GdkColormap * colormap, GdkVisual * visual,
  60                        GdkColor * color_def)
  61 {
  62         int rc;
  63
  64         rc = gdk_colormap_alloc_color(colormap, color_def, FALSE, TRUE);
  65
  66         if (rc == TRUE)
  67                 return (1);
  68
  69         return (0);
  70 }
  71
  72 int
  73 gtk_parse_nearest_color(struct device *d, GdkColor * color, Bufbyte * name,
  74                         Bytecount len, Error_behavior errb)
  75 {
  76         GdkColormap *cmap;
  77         GdkVisual *visual;
  78         int result;
  79
  80         cmap = DEVICE_GTK_COLORMAP(d);
  81         visual = DEVICE_GTK_VISUAL(d);
  82
  83         xzero(*color);
  84         {
  85                 const Extbyte *extname;
  86                 Extcount extnamelen;
  87
  88                 TO_EXTERNAL_FORMAT(DATA, (name, len), ALLOCA,
  89                                    (extname, extnamelen), Qbinary);
  90
  91                 result = gdk_color_parse(extname, color);
  92         }
  93
  94         if (result == FALSE) {
  95                 maybe_signal_simple_error("unrecognized color",
  96                                           make_string(name, len), Qcolor, errb);
  97                 return 0;
  98         }
  99         result = allocate_nearest_color(cmap, visual, color);
 100         if (!result) {
 101                 maybe_signal_simple_error("couldn't allocate color",
 102                                           make_string(name, len), Qcolor, errb);
 103                 return 0;
 104         }
 105
 106         return result;
 107 }
 108
 109 static int
 110 gtk_initialize_color_instance(struct Lisp_Color_Instance *c, Lisp_Object name,
 111                               Lisp_Object device, Error_behavior errb)
 112 {
 113         GdkColor color;
 114         int result;
 115
 116         result = gtk_parse_nearest_color(XDEVICE(device), &color,
 117                                          XSTRING_DATA(name),
 118                                          XSTRING_LENGTH(name), errb);
 119
 120         if (!result)
 121                 return 0;
 122
 123         /* Don't allocate the data until we're sure that we will succeed,
 124            or the finalize method may get fucked. */
 125         c->data = xnew(struct gtk_color_instance_data);
 126         if (result == 3)
 127                 COLOR_INSTANCE_GTK_DEALLOC(c) = 0;
 128         else
 129                 COLOR_INSTANCE_GTK_DEALLOC(c) = 1;
 130         COLOR_INSTANCE_GTK_COLOR(c) = gdk_color_copy(&color);
 131         return 1;
 132 }
 133
 134 static void
 135 gtk_print_color_instance(struct Lisp_Color_Instance *c,
 136                          Lisp_Object printcharfun, int escapeflag)
 137 {
 138         GdkColor *color = COLOR_INSTANCE_GTK_COLOR(c);
 139         write_fmt_str(printcharfun, " %ld=(%X,%X,%X)",
 140                       color->pixel, color->red, color->green, color->blue);
 141 }
 142
 143 static void gtk_finalize_color_instance(struct Lisp_Color_Instance *c)
 144 {
 145         if (c->data) {
 146                 if (DEVICE_LIVE_P(XDEVICE(c->device))) {
 147                         if (COLOR_INSTANCE_GTK_DEALLOC(c)) {
 148                                 gdk_colormap_free_colors(DEVICE_GTK_COLORMAP
 149                                                          (XDEVICE(c->device)),
 150                                                          COLOR_INSTANCE_GTK_COLOR
 151                                                          (c), 1);
 152                         }
 153                         gdk_color_free(COLOR_INSTANCE_GTK_COLOR(c));
 154                 }
 155                 xfree(c->data);
 156                 c->data = 0;
 157         }
 158 }
 159
 160 /* Color instances are equal if they resolve to the same color on the
 161    screen (have the same RGB values).  I imagine that
 162    "same RGB values" == "same cell in the colormap."  Arguably we should
 163    be comparing their names or pixel values instead. */
 164
 165 static int
 166 gtk_color_instance_equal(struct Lisp_Color_Instance *c1,
 167                          struct Lisp_Color_Instance *c2, int depth)
 168 {
 169         return (gdk_color_equal(COLOR_INSTANCE_GTK_COLOR(c1),
 170                                 COLOR_INSTANCE_GTK_COLOR(c2)));
 171 }
 172
 173 static unsigned long
 174 gtk_color_instance_hash(struct Lisp_Color_Instance *c, int depth)
 175 {
 176         return (gdk_color_hash(COLOR_INSTANCE_GTK_COLOR(c), NULL));
 177 }
 178
 179 static Lisp_Object
 180 gtk_color_instance_rgb_components(struct Lisp_Color_Instance *c)
 181 {
 182         GdkColor *color = COLOR_INSTANCE_GTK_COLOR(c);
 183         return (list3(make_int(color->red),
 184                       make_int(color->green), make_int(color->blue)));
 185 }
 186
 187 static int gtk_valid_color_name_p(struct device *d, Lisp_Object color)
 188 {
 189         GdkColor c;
 190         const char *extname;
 191
 192         TO_EXTERNAL_FORMAT(LISP_STRING, color, C_STRING_ALLOCA, extname,
 193                            Qctext);
 194
 195         if (gdk_color_parse(extname, &c) != TRUE)
 196                 return (0);
 197         return (1);
 198 }
 199 \f
 200 /************************************************************************/
 201 /*                           font instances                             */
 202 /************************************************************************/
 203
 204 static int
 205 gtk_initialize_font_instance(struct Lisp_Font_Instance *f, Lisp_Object name,
 206                              Lisp_Object device, Error_behavior errb)
 207 {
 208         GdkFont *gf;
 209         XFontStruct *xf;
 210         const char *extname;
 211
 212         TO_EXTERNAL_FORMAT(LISP_STRING, f->name, C_STRING_ALLOCA, extname,
 213                            Qctext);
 214
 215         gf = gdk_font_load(extname);
 216
 217         if (!gf) {
 218                 maybe_signal_simple_error("couldn't load font", f->name,
 219                                           Qfont, errb);
 220                 return 0;
 221         }
 222
 223         xf = GDK_FONT_XFONT(gf);
 224
 225         /* Don't allocate the data until we're sure that we will succeed,
 226            or the finalize method may get fucked. */
 227         f->data = xnew(struct gtk_font_instance_data);
 228         FONT_INSTANCE_GTK_TRUENAME(f) = Qnil;
 229         FONT_INSTANCE_GTK_FONT(f) = gf;
 230         f->ascent = gf->ascent;
 231         f->descent = gf->descent;
 232         f->height = gf->ascent + gf->descent;
 233
 234         /* Now lets figure out the width of the font */
 235         {
 236                 /* following change suggested by Ted Phelps <phelps@dstc.edu.au> */
 237                 unsigned int def_char = 'n';    /*xf->default_char; */
 238                 unsigned int byte1, byte2;
 239
 240               once_more:
 241                 byte1 = def_char >> 8;
 242                 byte2 = def_char & 0xFF;
 243
 244                 if (xf->per_char) {
 245                         /* Old versions of the R5 font server have garbage (>63k) as
 246                            def_char. 'n' might not be a valid character. */
 247                         if (byte1 < xf->min_byte1 ||
 248                             byte1 > xf->max_byte1 ||
 249                             byte2 < xf->min_char_or_byte2 ||
 250                             byte2 > xf->max_char_or_byte2)
 251                                 f->width = 0;
 252                         else
 253                                 f->width =
 254                                     xf->per_char[(byte1 - xf->min_byte1) *
 255                                                  (xf->max_char_or_byte2 -
 256                                                   xf->min_char_or_byte2 + 1) +
 257                                                  (byte2 -
 258                                                   xf->min_char_or_byte2)].width;
 259                 } else
 260                         f->width = xf->max_bounds.width;
 261
 262                 /* Some fonts have a default char whose width is 0.  This is no good.
 263                    If that's the case, first try 'n' as the default char, and if n has
 264                    0 width too (unlikely) then just use the max width. */
 265                 if (f->width == 0) {
 266                         if (def_char == xf->default_char)
 267                                 f->width = xf->max_bounds.width;
 268                         else {
 269                                 def_char = xf->default_char;
 270                                 goto once_more;
 271                         }
 272                 }
 273         }
 274
 275         /* If all characters don't exist then there could potentially be
 276            0-width characters lurking out there.  Not setting this flag
 277            trips an optimization that would make them appear to have width
 278            to redisplay.  This is bad.  So we set it if not all characters
 279            have the same width or if not all characters are defined.
 280          */
 281         /* #### This sucks.  There is a measurable performance increase
 282            when using proportional width fonts if this flag is not set.
 283            Unfortunately so many of the fucking X fonts are not fully
 284            defined that we could almost just get rid of this damn flag and
 285            make it an assertion. */
 286         f->proportional_p = (xf->min_bounds.width != xf->max_bounds.width ||
 287                              ( /* x_handle_non_fully_specified_fonts */ 0 &&
 288                               !xf->all_chars_exist));
 289 #if 0
 290         f->width = gdk_char_width(gf, 'n');
 291         f->proportional_p =
 292             (gdk_char_width(gf, '|') != gdk_char_width(gf, 'W')) ? 1 : 0;
 293 #endif
 294         return 1;
 295 }
 296
 297 static void gtk_mark_font_instance(struct Lisp_Font_Instance *f)
 298 {
 299         mark_object(FONT_INSTANCE_GTK_TRUENAME(f));
 300 }
 301
 302 static void
 303 gtk_print_font_instance(struct Lisp_Font_Instance *f,
 304                         Lisp_Object printcharfun, int escapeflag)
 305 {
 306         write_fmt_str(printcharfun, " 0x%lx",
 307                       (unsigned long)gdk_font_id(FONT_INSTANCE_GTK_FONT(f)));
 308 }
 309
 310 static void gtk_finalize_font_instance(struct Lisp_Font_Instance *f)
 311 {
 312         if (f->data) {
 313                 if (DEVICE_LIVE_P(XDEVICE(f->device))) {
 314                         gdk_font_unref(FONT_INSTANCE_GTK_FONT(f));
 315                 }
 316                 xfree(f->data);
 317                 f->data = 0;
 318         }
 319 }
 320
 321 /* Forward declarations for X specific functions at the end of the file */
 322 Lisp_Object __get_gtk_font_truename(GdkFont * gdk_font, int expandp);
 323 static Lisp_Object __gtk_list_fonts_internal(const char *pattern);
 324
 325 static Lisp_Object
 326 gtk_font_instance_truename(struct Lisp_Font_Instance *f, Error_behavior errb)
 327 {
 328         if (NILP(FONT_INSTANCE_GTK_TRUENAME(f))) {
 329                 FONT_INSTANCE_GTK_TRUENAME(f) =
 330                     __get_gtk_font_truename(FONT_INSTANCE_GTK_FONT(f), 1);
 331
 332                 if (NILP(FONT_INSTANCE_GTK_TRUENAME(f))) {
 333                         /* Ok, just this once, return the font name as the truename.
 334                            (This is only used by Fequal() right now.) */
 335                         return f->name;
 336                 }
 337         }
 338         return (FONT_INSTANCE_GTK_TRUENAME(f));
 339 }
 340
 341 static Lisp_Object gtk_font_instance_properties(struct Lisp_Font_Instance *f)
 342 {
 343         Lisp_Object result = Qnil;
 344
 345         /* #### BILL!!! */
 346         /* There seems to be no way to get this information under Gtk */
 347         return result;
 348 }
 349
 350 static Lisp_Object gtk_list_fonts(Lisp_Object pattern, Lisp_Object device)
 351 {
 352         const char *patternext;
 353
 354         TO_EXTERNAL_FORMAT(LISP_STRING, pattern, C_STRING_ALLOCA, patternext,
 355                            Qbinary);
 356
 357         return (__gtk_list_fonts_internal(patternext));
 358 }
 359
 360 #ifdef MULE
 361
 362 static int
 363 gtk_font_spec_matches_charset(struct device *d, Lisp_Object charset,
 364                               const Bufbyte * nonreloc, Lisp_Object reloc,
 365                               Bytecount offset, Bytecount length)
 366 {
 367         if (UNBOUNDP(charset))
 368                 return 1;
 369         /* Hack! Short font names don't have the registry in them,
 370            so we just assume the user knows what they're doing in the
 371            case of ASCII.  For other charsets, you gotta give the
 372            long form; sorry buster.
 373          */
 374         if (EQ(charset, Vcharset_ascii)) {
 375                 const Bufbyte *the_nonreloc = nonreloc;
 376                 int i;
 377                 Bytecount the_length = length;
 378
 379                 if (!the_nonreloc)
 380                         the_nonreloc = XSTRING_DATA(reloc);
 381                 fixup_internal_substring(nonreloc, reloc, offset, &the_length);
 382                 the_nonreloc += offset;
 383                 if (!memchr(the_nonreloc, '*', the_length)) {
 384                         for (i = 0;; i++) {
 385                                 const Bufbyte *new_nonreloc = (const Bufbyte *)
 386                                     memchr(the_nonreloc, '-', the_length);
 387                                 if (!new_nonreloc)
 388                                         break;
 389                                 new_nonreloc++;
 390                                 the_length -= new_nonreloc - the_nonreloc;
 391                                 the_nonreloc = new_nonreloc;
 392                         }
 393
 394                         /* If it has less than 5 dashes, it's a short font.
 395                            Of course, long fonts always have 14 dashes or so, but short
 396                            fonts never have more than 1 or 2 dashes, so this is some
 397                            sort of reasonable heuristic. */
 398                         if (i < 5)
 399                                 return 1;
 400                 }
 401         }
 402
 403         return (fast_string_match(XCHARSET_REGISTRY(charset),
 404                                   nonreloc, reloc, offset, length, 1,
 405                                   ERROR_ME, 0) >= 0);
 406 }
 407
 408 /* find a font spec that matches font spec FONT and also matches
 409    (the registry of) CHARSET. */
 410 static Lisp_Object gtk_find_charset_font(Lisp_Object device, Lisp_Object font,
 411                                          Lisp_Object charset);
 412
 413 #endif                          /* MULE */
 414 \f
 415 /************************************************************************/
 416 /*                            initialization                            */
 417 /************************************************************************/
 418
 419 void syms_of_objects_gtk(void)
 420 {
 421 }
 422
 423 void console_type_create_objects_gtk(void)
 424 {
 425         /* object methods */
 426
 427         CONSOLE_HAS_METHOD(gtk, initialize_color_instance);
 428         CONSOLE_HAS_METHOD(gtk, print_color_instance);
 429         CONSOLE_HAS_METHOD(gtk, finalize_color_instance);
 430         CONSOLE_HAS_METHOD(gtk, color_instance_equal);
 431         CONSOLE_HAS_METHOD(gtk, color_instance_hash);
 432         CONSOLE_HAS_METHOD(gtk, color_instance_rgb_components);
 433         CONSOLE_HAS_METHOD(gtk, valid_color_name_p);
 434
 435         CONSOLE_HAS_METHOD(gtk, initialize_font_instance);
 436         CONSOLE_HAS_METHOD(gtk, mark_font_instance);
 437         CONSOLE_HAS_METHOD(gtk, print_font_instance);
 438         CONSOLE_HAS_METHOD(gtk, finalize_font_instance);
 439         CONSOLE_HAS_METHOD(gtk, font_instance_truename);
 440         CONSOLE_HAS_METHOD(gtk, font_instance_properties);
 441         CONSOLE_HAS_METHOD(gtk, list_fonts);
 442 #ifdef MULE
 443         CONSOLE_HAS_METHOD(gtk, find_charset_font);
 444         CONSOLE_HAS_METHOD(gtk, font_spec_matches_charset);
 445 #endif
 446 }
 447
 448 void vars_of_objects_gtk(void)
 449 {
 450 }
 451
 452 /* #### BILL!!! Try to make this go away eventually */
 453 /* X Specific stuff */
 454 #include <X11/Xatom.h>
 455
 456 /* Unbounded, for sufficiently small values of infinity... */
 457 #define MAX_FONT_COUNT 5000
 458
 459 #ifdef MULE
 460 /* find a font spec that matches font spec FONT and also matches
 461    (the registry of) CHARSET. */
 462 static Lisp_Object
 463 gtk_find_charset_font(Lisp_Object device, Lisp_Object font, Lisp_Object charset)
 464 {
 465         char **names;
 466         int count = 0;
 467         Lisp_Object result = Qnil;
 468         const char *patternext;
 469         int i;
 470
 471         TO_EXTERNAL_FORMAT(LISP_STRING, font, C_STRING_ALLOCA, patternext,
 472                            Qbinary);
 473
 474         names = XListFonts(GDK_DISPLAY(), patternext, MAX_FONT_COUNT, &count);
 475         /* ### This code seems awfully bogus -- mrb */
 476         for (i = 0; i < count; i++) {
 477                 const Bufbyte *intname;
 478                 Bytecount intlen;
 479
 480                 TO_INTERNAL_FORMAT(C_STRING, names[i], ALLOCA,
 481                                    (intname, intlen), Qctext);
 482                 if (gtk_font_spec_matches_charset
 483                     (XDEVICE(device), charset, intname, Qnil, 0, -1)) {
 484                         result = make_string((char *)intname, intlen);
 485                         break;
 486                 }
 487         }
 488
 489         if (names)
 490                 XFreeFontNames(names);
 491
 492         /* Check for a short font name. */
 493         if (NILP(result)
 494             && gtk_font_spec_matches_charset(XDEVICE(device), charset, 0,
 495                                              font, 0, -1))
 496                 return font;
 497
 498         return result;
 499 }
 500 #endif                          /* MULE */
 501
 502 /* Unbounded, for sufficiently small values of infinity... */
 503 #define MAX_FONT_COUNT 5000
 504
 505 static int valid_font_name_p(Display * dpy, char *name)
 506 {
 507         /* Maybe this should be implemented by callign XLoadFont and trapping
 508            the error.  That would be a lot of work, and wasteful as hell, but
 509            might be more correct.
 510          */
 511         int nnames = 0;
 512         char **names = 0;
 513         if (!name)
 514                 return 0;
 515         names = XListFonts(dpy, name, 1, &nnames);
 516         if (names)
 517                 XFreeFontNames(names);
 518         return (nnames != 0);
 519 }
 520
 521 Lisp_Object __get_gtk_font_truename(GdkFont * gdk_font, int expandp)
 522 {
 523         Display *dpy = GDK_FONT_XDISPLAY(gdk_font);
 524         GSList *names = ((GdkFontPrivate *) gdk_font)->names;
 525         Lisp_Object font_name = Qnil;
 526
 527         while (names) {
 528                 if (names->data) {
 529                         if (valid_font_name_p(dpy, names->data)) {
 530                                 if (!expandp) {
 531                                         /* They want the wildcarded version */
 532                                         font_name = build_string(names->data);
 533                                 } else {
 534                                         /* Need to expand out */
 535                                         int nnames = 0;
 536                                         char **x_font_names = 0;
 537
 538                                         x_font_names =
 539                                             XListFonts(dpy, names->data, 1,
 540                                                        &nnames);
 541                                         if (x_font_names) {
 542                                                 font_name =
 543                                                     build_string(x_font_names
 544                                                                  [0]);
 545                                                 XFreeFontNames(x_font_names);
 546                                         }
 547                                 }
 548                                 break;
 549                         }
 550                 }
 551                 names = names->next;
 552         }
 553         return (font_name);
 554 }
 555
 556 static Lisp_Object __gtk_list_fonts_internal(const char *pattern)
 557 {
 558         char **names;
 559         int count = 0;
 560         Lisp_Object result = Qnil;
 561
 562         names = XListFonts(GDK_DISPLAY(), pattern, MAX_FONT_COUNT, &count);
 563         while (count--)
 564                 result = Fcons(build_ext_string(names[count], Qbinary), result);
 565         if (names)
 566                 XFreeFontNames(names);
 567
 568         return result;
 569 }