cgit.sxemacs.org Git - sxemacs/blob - src/ui/TTY/objects-tty.c

   1 /* TTY-specific Lisp objects.
   2    Copyright (C) 1995 Board of Trustees, University of Illinois.
   3    Copyright (C) 1995, 1996 Ben Wing.
   4    Copyright (C) 2007, 2008 Nelson Ferreira
   5
   6 This file is part of SXEmacs
   7
   8 SXEmacs is free software: you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation, either version 3 of the License, or
  11 (at your option) any later version.
  12
  13 SXEmacs is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  20
  21
  22 /* Synched up with: Not in FSF. */
  23
  24 #include <config.h>
  25 #include "lisp.h"
  26
  27 #include "console-tty.h"
  28 #include "ui/insdel.h"
  29 #include "objects-tty.h"
  30 #ifdef MULE
  31 #include "ui/device.h"
  32 #include "mule/mule-charset.h"
  33 #endif
  34 #include "skiplist.h"
  35
  36 /* Term => ( color => '(index bold) ) */
  37 Lisp_Object Vterm_color_alias_slist;
  38
  39 /* Term => ( [r g b] => '(index bold) ) */
  40 Lisp_Object Vterm_color_map_slist;
  41
  42
  43 Lisp_Object Qx_nearest_color;
  44
  45 static inline Lisp_Object
  46 get_term_color_alias_slist( Lisp_Object sym_term, unsigned create )
  47         __attribute__((always_inline));
  48
  49 static inline Lisp_Object
  50 get_term_color_alias_slist( Lisp_Object sym_term, unsigned create )
  51 {
  52         Lisp_Object color_slist = Qnil;
  53
  54         if ( EQ(Vterm_color_alias_slist,Qnil) ) {
  55                 Vterm_color_alias_slist = make_skiplist();
  56         } else {
  57                 assert(SKIPLISTP(Vterm_color_alias_slist));
  58                 color_slist = get_skiplist(XSKIPLIST(Vterm_color_alias_slist),
  59                                            sym_term, Qnil);
  60         }
  61         if ( EQ(color_slist,Qnil) ) {
  62                 if ( create ) {
  63                         color_slist = make_skiplist();
  64                 }
  65         } else {
  66                 assert(SKIPLISTP(color_slist));
  67         }
  68         return color_slist;
  69 }
  70
  71 static inline Lisp_Object
  72 get_term_color_map_slist( Lisp_Object sym_term, unsigned create )
  73         __attribute__((always_inline));
  74 static inline Lisp_Object
  75 get_term_color_map_slist( Lisp_Object sym_term, unsigned create )
  76 {
  77         Lisp_Object map_slist = Qnil;
  78
  79         if ( EQ(Vterm_color_map_slist,Qnil) ) {
  80                 Vterm_color_map_slist = make_skiplist();
  81         } else {
  82                 assert(SKIPLISTP(Vterm_color_map_slist));
  83                 map_slist = get_skiplist(XSKIPLIST(Vterm_color_map_slist),
  84                                          sym_term, Qnil);
  85         }
  86         if ( EQ(map_slist,Qnil) ) {
  87                 if ( create ) {
  88                         map_slist = make_skiplist();
  89                 }
  90         } else {
  91                 assert(SKIPLISTP(map_slist));
  92         }
  93         return map_slist;
  94 }
  95
  96
  97
  98 DEFUN("register-tty-color-index", Fregister_tty_color_index, 6, 7, 0, /*
  99 Register COLOR as recognized by TERM with index IDX and RED, GREEN and BLUE
 100 components.
 101 RED, GREEN and BLUE is expected to be in the range 0 through 65535
 102 */
 103       (term,color,idx,red,green,blue,bold))
 104 {
 105         Lisp_Object sym_term = Qnil;
 106         Lisp_Object sym_color = Qnil;
 107         Lisp_Object rgb_tuple = Qnil;
 108         Lisp_Object idx_tuple = Qnil;
 109         Lisp_Object map_slist = Qnil;
 110         Lisp_Object color_slist = Qnil;
 111
 112         /* Validating the parameter types */
 113         CHECK_INT(idx);
 114         CHECK_INT_OR_FLOAT(red);
 115         CHECK_INT_OR_FLOAT(green);
 116         CHECK_INT_OR_FLOAT(blue);
 117         CHECK_SYMBOL(bold);
 118
 119         /* term and color can be given as symbols or strings.
 120            if given as strings we auto-intern them
 121         */
 122         if( RECORD_TYPEP(term, lrecord_type_symbol) ) {
 123                 sym_term = term;
 124         } else if ( RECORD_TYPEP(term, lrecord_type_string) ) {
 125                 sym_term = Fintern(term,Qnil);
 126         } else {
 127                 dead_wrong_type_argument(Qstringp,term);
 128         }
 129         if( RECORD_TYPEP(color, lrecord_type_symbol) ) {
 130                 sym_color = color;
 131         } else if ( RECORD_TYPEP(color, lrecord_type_string) ) {
 132                 sym_color = Fintern(color,Qnil);
 133         } else {
 134                 dead_wrong_type_argument(Qstringp,color);
 135         }
 136
 137         color_slist = get_term_color_alias_slist(sym_term, 1);
 138         map_slist = get_term_color_map_slist(sym_term, 1);
 139
 140         /* Updating the skiplists
 141          */
 142         rgb_tuple = make_vector(3,Qnil);
 143         Faset(rgb_tuple, make_int(0), red);
 144         Faset(rgb_tuple, make_int(1), green);
 145         Faset(rgb_tuple, make_int(2), blue);
 146
 147         {       /* Build the index tuple */
 148                 Lisp_Object list_args[2];
 149
 150                 list_args[0] = idx;
 151                 list_args[1] = bold;
 152                 idx_tuple = Flist(2, list_args);
 153         }
 154
 155         /* Add the color alias */
 156         put_skiplist( XSKIPLIST(color_slist),sym_color,idx_tuple);
 157         put_skiplist( XSKIPLIST(Vterm_color_alias_slist),
 158                       term, color_slist);
 159         /* Add the index rgb */
 160         put_skiplist( XSKIPLIST(map_slist),rgb_tuple,idx_tuple);
 161         put_skiplist( XSKIPLIST(Vterm_color_map_slist),
 162                       term, map_slist);
 163         return Qnil;
 164 }
 165
 166
 167 static Lisp_Object tty_slist_keyname_accum( Lisp_Object key, Lisp_Object val, void* accum)
 168 {
 169         Lisp_Object *result = (Lisp_Object*)accum;
 170         *result = Fcons(Fsymbol_name(key), *result);
 171         return *result;
 172 }
 173
 174 static Lisp_Object tty_slist_key_accum( Lisp_Object key, Lisp_Object val, void* accum)
 175 {
 176         Lisp_Object *result = (Lisp_Object*)accum;
 177         *result = Fcons(key, *result);
 178         return *result;
 179 }
 180
 181 static Lisp_Object nearest_color_slist( Lisp_Object sym_color, Lisp_Object slist )
 182 {
 183         Lisp_Object rgblist = Qnil;
 184         Lisp_Object result = Qnil;
 185
 186         map2_skiplist(XSKIPLIST(slist), tty_slist_key_accum, &rgblist );
 187         result = call2_trapping_errors( "Error_nearest_color",
 188                                         Qx_nearest_color,
 189                                         sym_color, rgblist );
 190         return result;
 191 }
 192
 193
 194 DEFUN("find-tty-color", Ffind_tty_color, 1, 3, 0,       /*
 195 Look up COLOR in the list of registered TTY colors for DEVICE or NEAREST.
 196 DEVICE defaults to the selected device if omitted.
 197 If it is found, return a list (INDEX BOLD) used to set the foreground to the color.
 198 If it is not found, return nil.
 199 If NEAREST is non-nil and an exact match was not found, find and return
 200 the nearest available color.
 201 */
 202       (color,device,nearest))
 203 {
 204         Lisp_Object result = Qnil;
 205         Lisp_Object console = Qnil;
 206         Lisp_Object color_slist = Qnil;
 207         Lisp_Object default_color_slist = Qnil;
 208         Lisp_Object default_term_slist = Qnil;
 209         Lisp_Object this_term_slist = Qnil;
 210         Lisp_Object sym_color =Qnil;
 211         Lisp_Object sym_term = Qnil;
 212
 213         if ( EQ(device,Qnil) ) {
 214                 device = Fselected_device(Qnil);
 215         }
 216         console=Fdevice_console(device);
 217         if ( ! CONSOLEP(console) || ! CONSOLE_TYPE_P (XCONSOLE (console), tty) )
 218                 dead_wrong_type_argument(Qconsolep,console);
 219
 220
 221         if( RECORD_TYPEP(color, lrecord_type_symbol) ) {
 222                 sym_color = color;
 223         } else if ( RECORD_TYPEP(color, lrecord_type_string) ) {
 224                 sym_color = Fintern(color,Qnil);
 225         } else {
 226                 dead_wrong_type_argument(Qstringp,color);
 227         }
 228
 229         /* First check if there is a term-specific map */
 230         this_term_slist = color_slist = CONSOLE_TTY_DATA(console)->term_cmap;
 231         if ( ! EQ(color_slist,Qnil) ) {
 232                 result = Fget_skiplist(color_slist, sym_color, Qnil);
 233         }
 234         if ( EQ(result,Qnil) ) {
 235                 /* If not, let's try the term */
 236                 default_term_slist = color_slist =
 237                         get_term_color_alias_slist(
 238                                 CONSOLE_TTY_DATA(console)->terminal_type,0);
 239                 if ( ! EQ(color_slist,Qnil) ) {
 240                         result = Fget_skiplist(color_slist, sym_color, Qnil);
 241                 }
 242         }
 243         if ( EQ(result,Qnil) ) {
 244                 /* Last resort: the default based on the colors */
 245                 char term_name[25];
 246                 snprintf(term_name,24,"default-%d-color",
 247                          CONSOLE_TTY_DATA(console)->maxcolors);
 248                 sym_term = Fintern(make_string((Bufbyte*)term_name,strlen(term_name)),Qnil);
 249                 default_color_slist = color_slist = get_term_color_alias_slist(sym_term,0);
 250                 if ( ! EQ(color_slist,Qnil) ) {
 251                         result = Fget_skiplist(color_slist, sym_color, Qnil);
 252                 }
 253         }
 254         if ( EQ(result,Qnil) && ! EQ(nearest, Qnil) ) {
 255                 Lisp_Object color_alist = Qnil;
 256                 Lisp_Object default_color_alist = Qnil;
 257                 Lisp_Object default_term_alist = Qnil;
 258                 Lisp_Object this_term_alist = Qnil;
 259                 Lisp_Object nearest_rgb = Qnil;
 260                 Lisp_Object args[2];
 261
 262                 /* Lets build the supreme list :) Starting with the
 263                  * default color, then terminal name, then specific
 264                  * tty.  This way we get actual override of color defs
 265                  * in the more specific definitions.
 266                  */
 267                 /* NOTE: sym_term was filled above... */
 268                 default_color_alist = color_alist = get_term_color_map_slist(sym_term,0);
 269                 args[0] = color_alist;
 270                 default_term_alist = args[1] =
 271                         get_term_color_map_slist(CONSOLE_TTY_DATA(console)->terminal_type,0);
 272                 if ( ! EQ(args[1],Qnil) ) {
 273                         color_alist = Fnconc(2,args);
 274                         args[0] = color_alist;
 275                 }
 276                 this_term_alist = args[1] = CONSOLE_TTY_DATA(console)->term_crgb;
 277                 if ( ! EQ(args[1],Qnil) ) {
 278                         color_alist = Fnconc(2,args);
 279                 }
 280                 if ( ! EQ(color_alist,Qnil) ) {
 281                         nearest_rgb = nearest_color_slist( sym_color, color_alist );
 282                 }
 283                 if ( ! EQ(nearest_rgb, Qnil) ) {
 284                         /* Let's find out where this result comes from ;-) */
 285                         int cached = 0;
 286                         if ( ! EQ(this_term_alist, Qnil) ) {
 287                                 result = Fget_skiplist(this_term_alist, nearest_rgb, Qnil);
 288                                 if ( ! EQ(result, Qnil) ) {
 289                                         put_skiplist( XSKIPLIST(this_term_slist),sym_color,result);
 290                                         CONSOLE_TTY_DATA(console)->term_cmap = this_term_slist;
 291                                         cached = 1;
 292                                 }
 293                         }
 294                         if ( ! cached && ! EQ(default_term_alist, Qnil) &&
 295                              ! EQ(default_term_slist, Qnil) ) {
 296                                 result = Fget_skiplist(default_term_alist, nearest_rgb, Qnil);
 297                                 if ( ! EQ(result, Qnil) ) {
 298                                         put_skiplist( XSKIPLIST(default_term_slist),sym_color,result);
 299                                         put_skiplist( XSKIPLIST(Vterm_color_alias_slist),
 300                                                       CONSOLE_TTY_DATA(console)->terminal_type,
 301                                                       default_term_slist);
 302                                         cached = 1;
 303                                 }
 304                         }
 305                         if ( ! cached && ! EQ(default_color_alist, Qnil) &&
 306                              ! EQ(default_color_slist, Qnil) ) {
 307                                 result = Fget_skiplist(default_color_alist, nearest_rgb, Qnil);
 308                                 if ( ! EQ(result, Qnil) ) {
 309                                         put_skiplist( XSKIPLIST(default_color_slist),sym_color,result);
 310                                         put_skiplist( XSKIPLIST(Vterm_color_alias_slist),
 311                                                       sym_term, default_color_slist);
 312                                         cached = 1;
 313                                 }
 314                         }
 315                 }
 316         }
 317         return result;
 318 }
 319
 320
 321
 322 DEFUN("tty-registered-color-list", Ftty_registered_color_list, 0, 1, 0, /*
 323 Return a list of the registered TTY colors FOR DEVICE.
 324 DEVICE defaults to the selected device if omitted.
 325 */
 326       (device))
 327 {
 328         Lisp_Object result = Qnil;
 329         Lisp_Object console = Qnil;
 330         Lisp_Object color_slist = Qnil;
 331
 332         if ( ! EQ(device,Qnil) ) {
 333                 device = Fselected_device(Qnil);
 334         }
 335         console=Fdevice_console(device);
 336         /* First check if there is a term-specific map */
 337         color_slist = CONSOLE_TTY_DATA(console)->term_cmap;
 338         if ( EQ(color_slist,Qnil) ) {
 339                 /* If not, let's try the term */
 340                 color_slist = get_term_color_alias_slist(
 341                         CONSOLE_TTY_DATA(console)->terminal_type,0);
 342         }
 343         if ( EQ(color_slist,Qnil) ) {
 344                 /* Last resort: the default based on the colors */
 345                 char term_name[25];
 346                 Lisp_Object sym_term;
 347                 snprintf(term_name,24,"default-%d-color",
 348                          CONSOLE_TTY_DATA(console)->maxcolors);
 349                 sym_term = Fintern(make_string((Bufbyte*)term_name,strlen(term_name)),Qnil);
 350                 color_slist = get_term_color_alias_slist(sym_term,0);
 351         }
 352         if ( ! EQ(color_slist,Qnil) ) {
 353                 map2_skiplist(XSKIPLIST(color_slist), tty_slist_keyname_accum, &result );
 354         }
 355         return result;
 356 }
 357
 358
 359 static int
 360 tty_initialize_color_instance(Lisp_Color_Instance * c, Lisp_Object name,
 361                               Lisp_Object device, Error_behavior errb)
 362 {
 363 /* This function does not GC */
 364         Lisp_Object result;
 365         Lisp_Object sym_color;
 366
 367         if( RECORD_TYPEP(name, lrecord_type_symbol) ) {
 368                 sym_color = name;
 369         } else if ( RECORD_TYPEP(name, lrecord_type_string) ) {
 370                 sym_color = Fintern(name,Qnil);
 371         } else {
 372                 dead_wrong_type_argument(Qstringp,name);
 373         }
 374
 375         result = Ffind_tty_color( sym_color, device, Qt);
 376
 377         if (NILP(result)) {
 378                 c->data = NULL;
 379                 return 0;
 380         }
 381
 382         /* Don't allocate the data until we're sure that we will succeed. */
 383         c->data = xnew(struct tty_color_instance_data);
 384         if ( ! c->data ) {
 385                 return 0;
 386         }
 387
 388         COLOR_INSTANCE_TTY_SYMBOL(c) = sym_color;
 389         return 1;
 390 }
 391
 392 static void tty_mark_color_instance(Lisp_Color_Instance * c)
 393 {
 394         if ( TTY_COLOR_INSTANCE_DATA(c) )
 395                 mark_object(COLOR_INSTANCE_TTY_SYMBOL(c));
 396 }
 397
 398 static void
 399 tty_print_color_instance(Lisp_Color_Instance * c,
 400                          Lisp_Object printcharfun, int escapeflag)
 401 {
 402 }
 403
 404 static void tty_finalize_color_instance(Lisp_Color_Instance * c)
 405 {
 406         if (c->data)
 407                 xfree(c->data);
 408 }
 409
 410 static int
 411 tty_color_instance_equal(Lisp_Color_Instance * c1,
 412                          Lisp_Color_Instance * c2, int depth)
 413 {
 414         return (EQ(COLOR_INSTANCE_TTY_SYMBOL(c1),
 415                    COLOR_INSTANCE_TTY_SYMBOL(c2)));
 416 }
 417
 418 static unsigned long tty_color_instance_hash(Lisp_Color_Instance * c, int depth)
 419 {
 420         return LISP_HASH(COLOR_INSTANCE_TTY_SYMBOL(c));
 421 }
 422
 423 static int tty_valid_color_name_p(struct device *d, Lisp_Object color)
 424 {
 425         return (!NILP(Ffind_tty_color( color, wrap_object(d), Qt)));
 426 }
 427 \f
 428 static int
 429 tty_initialize_font_instance(Lisp_Font_Instance * f, Lisp_Object name,
 430                              Lisp_Object device, Error_behavior errb)
 431 {
 432         Bufbyte *str = XSTRING_DATA(name);
 433         Lisp_Object charset = Qnil;
 434
 435         if (strncmp((const char *)str, "normal", 6))
 436                 return 0;
 437         str += 6;
 438         if (*str) {
 439 #ifdef MULE
 440                 if (*str != '/')
 441                         return 0;
 442                 str++;
 443                 charset = Ffind_charset(intern((const char *)str));
 444                 if (NILP(charset))
 445                         return 0;
 446 #else
 447                 return 0;
 448 #endif
 449         }
 450
 451         /* Don't allocate the data until we're sure that we will succeed. */
 452         f->data = xnew(struct tty_font_instance_data);
 453         FONT_INSTANCE_TTY_CHARSET(f) = charset;
 454 #ifdef MULE
 455         if (CHARSETP(charset))
 456                 f->width = XCHARSET_COLUMNS(charset);
 457         else
 458 #endif
 459                 f->width = 1;
 460
 461         f->proportional_p = 0;
 462         f->ascent = f->height = 1;
 463         f->descent = 0;
 464
 465         return 1;
 466 }
 467
 468 static void tty_mark_font_instance(Lisp_Font_Instance * f)
 469 {
 470         mark_object(FONT_INSTANCE_TTY_CHARSET(f));
 471 }
 472
 473 static void
 474 tty_print_font_instance(Lisp_Font_Instance * f,
 475                         Lisp_Object printcharfun, int escapeflag)
 476 {
 477 }
 478
 479 static void tty_finalize_font_instance(Lisp_Font_Instance * f)
 480 {
 481         if (f->data)
 482                 xfree(f->data);
 483 }
 484
 485 static Lisp_Object tty_list_fonts(Lisp_Object pattern, Lisp_Object device)
 486 {
 487         return list1(build_string("normal"));
 488 }
 489
 490 #ifdef MULE
 491
 492 static int
 493 tty_font_spec_matches_charset(struct device *d, Lisp_Object charset,
 494                               const Bufbyte * nonreloc, Lisp_Object reloc,
 495                               Bytecount offset, Bytecount length)
 496 {
 497         const Bufbyte *the_nonreloc = nonreloc;
 498
 499         if (!the_nonreloc)
 500                 the_nonreloc = XSTRING_DATA(reloc);
 501         fixup_internal_substring(nonreloc, reloc, offset, &length);
 502         the_nonreloc += offset;
 503
 504         if (UNBOUNDP(charset))
 505                 return !memchr(the_nonreloc, '/', length);
 506         the_nonreloc = (const Bufbyte *)memchr(the_nonreloc, '/', length);
 507         if (!the_nonreloc)
 508                 return 0;
 509         the_nonreloc++;
 510         {
 511                 Lisp_String *s = symbol_name(XSYMBOL(XCHARSET_NAME(charset)));
 512                 return !strcmp((const char *)the_nonreloc,
 513                                (const char *)string_data(s));
 514         }
 515 }
 516
 517 /* find a font spec that matches font spec FONT and also matches
 518    (the registry of) CHARSET. */
 519 static Lisp_Object
 520 tty_find_charset_font(Lisp_Object device, Lisp_Object font, Lisp_Object charset)
 521 {
 522         Bufbyte *fontname = XSTRING_DATA(font);
 523
 524         if (strchr((const char *)fontname, '/')) {
 525                 if (tty_font_spec_matches_charset(XDEVICE(device), charset, 0,
 526                                                   font, 0, -1))
 527                         return font;
 528                 return Qnil;
 529         }
 530
 531         if (UNBOUNDP(charset))
 532                 return font;
 533
 534         return concat3(font, build_string("/"),
 535                        Fsymbol_name(XCHARSET_NAME(charset)));
 536 }
 537
 538 #endif                          /* MULE */
 539 \f
 540 /************************************************************************/
 541 /*                            initialization                            */
 542 /************************************************************************/
 543
 544 void syms_of_objects_tty(void)
 545 {
 546         DEFSUBR(Fregister_tty_color_index);
 547         DEFSUBR(Ffind_tty_color);
 548         DEFSUBR(Ftty_registered_color_list);
 549         defsymbol(&Qx_nearest_color, "x-nearest-color");
 550 }
 551
 552 void console_type_create_objects_tty(void)
 553 {
 554         /* object methods */
 555         CONSOLE_HAS_METHOD(tty, initialize_color_instance);
 556         CONSOLE_HAS_METHOD(tty, mark_color_instance);
 557         CONSOLE_HAS_METHOD(tty, print_color_instance);
 558         CONSOLE_HAS_METHOD(tty, finalize_color_instance);
 559         CONSOLE_HAS_METHOD(tty, color_instance_equal);
 560         CONSOLE_HAS_METHOD(tty, color_instance_hash);
 561         CONSOLE_HAS_METHOD(tty, valid_color_name_p);
 562
 563         CONSOLE_HAS_METHOD(tty, initialize_font_instance);
 564         CONSOLE_HAS_METHOD(tty, mark_font_instance);
 565         CONSOLE_HAS_METHOD(tty, print_font_instance);
 566         CONSOLE_HAS_METHOD(tty, finalize_font_instance);
 567         CONSOLE_HAS_METHOD(tty, list_fonts);
 568 #ifdef MULE
 569         CONSOLE_HAS_METHOD(tty, font_spec_matches_charset);
 570         CONSOLE_HAS_METHOD(tty, find_charset_font);
 571 #endif
 572 }
 573
 574 void vars_of_objects_tty(void)
 575 {
 576         DEFVAR_LISP("term-color-alias-slist", &Vterm_color_alias_slist  /*
 577 Term => ( color => '(index bold) )
 578                                                                  */ );
 579         DEFVAR_LISP("term-color-map-slist", &Vterm_color_map_slist      /*
 580 Term => ( [r g b] => '(index bold) )
 581                                                                  */ );
 582         /*
 583         staticpro(&Vterm_color_alias_slist);
 584         staticpro(&Vterm_color_map_slist);
 585         */
 586         Vterm_color_alias_slist = Qnil;
 587         Vterm_color_map_slist = Qnil;
 588 }
 589