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[32];
 246                 int sz = snprintf(term_name,sizeof(term_name),"default-%d-color",
 247                                   CONSOLE_TTY_DATA(console)->maxcolors);
 248                 assert(sz >= 0 && (size_t)sz < sizeof(term_name));
 249                 sym_term = Fintern(make_string((Bufbyte*)term_name,strlen(term_name)),Qnil);
 250                 default_color_slist = color_slist = get_term_color_alias_slist(sym_term,0);
 251                 if ( ! EQ(color_slist,Qnil) ) {
 252                         result = Fget_skiplist(color_slist, sym_color, Qnil);
 253                 }
 254         }
 255         if ( EQ(result,Qnil) && ! EQ(nearest, Qnil) ) {
 256                 Lisp_Object color_alist = Qnil;
 257                 Lisp_Object default_color_alist = Qnil;
 258                 Lisp_Object default_term_alist = Qnil;
 259                 Lisp_Object this_term_alist = Qnil;
 260                 Lisp_Object nearest_rgb = Qnil;
 261                 Lisp_Object args[2];
 262
 263                 /* Lets build the supreme list :) Starting with the
 264                  * default color, then terminal name, then specific
 265                  * tty.  This way we get actual override of color defs
 266                  * in the more specific definitions.
 267                  */
 268                 /* NOTE: sym_term was filled above... */
 269                 default_color_alist = color_alist = get_term_color_map_slist(sym_term,0);
 270                 args[0] = color_alist;
 271                 default_term_alist = args[1] =
 272                         get_term_color_map_slist(CONSOLE_TTY_DATA(console)->terminal_type,0);
 273                 if ( ! EQ(args[1],Qnil) ) {
 274                         color_alist = Fnconc(2,args);
 275                         args[0] = color_alist;
 276                 }
 277                 this_term_alist = args[1] = CONSOLE_TTY_DATA(console)->term_crgb;
 278                 if ( ! EQ(args[1],Qnil) ) {
 279                         color_alist = Fnconc(2,args);
 280                 }
 281                 if ( ! EQ(color_alist,Qnil) ) {
 282                         nearest_rgb = nearest_color_slist( sym_color, color_alist );
 283                 }
 284                 if ( ! EQ(nearest_rgb, Qnil) ) {
 285                         /* Let's find out where this result comes from ;-) */
 286                         int cached = 0;
 287                         if ( ! EQ(this_term_alist, Qnil) ) {
 288                                 result = Fget_skiplist(this_term_alist, nearest_rgb, Qnil);
 289                                 if ( ! EQ(result, Qnil) ) {
 290                                         put_skiplist( XSKIPLIST(this_term_slist),sym_color,result);
 291                                         CONSOLE_TTY_DATA(console)->term_cmap = this_term_slist;
 292                                         cached = 1;
 293                                 }
 294                         }
 295                         if ( ! cached && ! EQ(default_term_alist, Qnil) &&
 296                              ! EQ(default_term_slist, Qnil) ) {
 297                                 result = Fget_skiplist(default_term_alist, nearest_rgb, Qnil);
 298                                 if ( ! EQ(result, Qnil) ) {
 299                                         put_skiplist( XSKIPLIST(default_term_slist),sym_color,result);
 300                                         put_skiplist( XSKIPLIST(Vterm_color_alias_slist),
 301                                                       CONSOLE_TTY_DATA(console)->terminal_type,
 302                                                       default_term_slist);
 303                                         cached = 1;
 304                                 }
 305                         }
 306                         if ( ! cached && ! EQ(default_color_alist, Qnil) &&
 307                              ! EQ(default_color_slist, Qnil) ) {
 308                                 result = Fget_skiplist(default_color_alist, nearest_rgb, Qnil);
 309                                 if ( ! EQ(result, Qnil) ) {
 310                                         put_skiplist( XSKIPLIST(default_color_slist),sym_color,result);
 311                                         put_skiplist( XSKIPLIST(Vterm_color_alias_slist),
 312                                                       sym_term, default_color_slist);
 313                                         cached = 1;
 314                                 }
 315                         }
 316                 }
 317         }
 318         return result;
 319 }
 320
 321
 322
 323 DEFUN("tty-registered-color-list", Ftty_registered_color_list, 0, 1, 0, /*
 324 Return a list of the registered TTY colors FOR DEVICE.
 325 DEVICE defaults to the selected device if omitted.
 326 */
 327       (device))
 328 {
 329         Lisp_Object result = Qnil;
 330         Lisp_Object console = Qnil;
 331         Lisp_Object color_slist = Qnil;
 332
 333         if ( ! EQ(device,Qnil) ) {
 334                 device = Fselected_device(Qnil);
 335         }
 336         console=Fdevice_console(device);
 337         /* First check if there is a term-specific map */
 338         color_slist = CONSOLE_TTY_DATA(console)->term_cmap;
 339         if ( EQ(color_slist,Qnil) ) {
 340                 /* If not, let's try the term */
 341                 color_slist = get_term_color_alias_slist(
 342                         CONSOLE_TTY_DATA(console)->terminal_type,0);
 343         }
 344         if ( EQ(color_slist,Qnil) ) {
 345                 /* Last resort: the default based on the colors */
 346                 char term_name[32];
 347                 Lisp_Object sym_term;
 348                 int sz = snprintf(term_name,sizeof(term_name),"default-%d-color",
 349                                   CONSOLE_TTY_DATA(console)->maxcolors);
 350                 assert(sz>=0 && (size_t)sz < sizeof(term_name));
 351                 sym_term = Fintern(make_string((Bufbyte*)term_name,strlen(term_name)),Qnil);
 352                 color_slist = get_term_color_alias_slist(sym_term,0);
 353         }
 354         if ( ! EQ(color_slist,Qnil) ) {
 355                 map2_skiplist(XSKIPLIST(color_slist), tty_slist_keyname_accum, &result );
 356         }
 357         return result;
 358 }
 359
 360
 361 static int
 362 tty_initialize_color_instance(Lisp_Color_Instance * c, Lisp_Object name,
 363                               Lisp_Object device, Error_behavior errb)
 364 {
 365 /* This function does not GC */
 366         Lisp_Object result;
 367         Lisp_Object sym_color;
 368
 369         if( RECORD_TYPEP(name, lrecord_type_symbol) ) {
 370                 sym_color = name;
 371         } else if ( RECORD_TYPEP(name, lrecord_type_string) ) {
 372                 sym_color = Fintern(name,Qnil);
 373         } else {
 374                 dead_wrong_type_argument(Qstringp,name);
 375         }
 376
 377         result = Ffind_tty_color( sym_color, device, Qt);
 378
 379         if (NILP(result)) {
 380                 c->data = NULL;
 381                 return 0;
 382         }
 383
 384         /* Don't allocate the data until we're sure that we will succeed. */
 385         c->data = xnew(struct tty_color_instance_data);
 386         if ( ! c->data ) {
 387                 return 0;
 388         }
 389
 390         COLOR_INSTANCE_TTY_SYMBOL(c) = sym_color;
 391         return 1;
 392 }
 393
 394 static void tty_mark_color_instance(Lisp_Color_Instance * c)
 395 {
 396         if ( TTY_COLOR_INSTANCE_DATA(c) )
 397                 mark_object(COLOR_INSTANCE_TTY_SYMBOL(c));
 398 }
 399
 400 static void
 401 tty_print_color_instance(Lisp_Color_Instance * c,
 402                          Lisp_Object printcharfun, int escapeflag)
 403 {
 404 }
 405
 406 static void tty_finalize_color_instance(Lisp_Color_Instance * c)
 407 {
 408         if (c->data)
 409                 xfree(c->data);
 410 }
 411
 412 static int
 413 tty_color_instance_equal(Lisp_Color_Instance * c1,
 414                          Lisp_Color_Instance * c2, int depth)
 415 {
 416         return (EQ(COLOR_INSTANCE_TTY_SYMBOL(c1),
 417                    COLOR_INSTANCE_TTY_SYMBOL(c2)));
 418 }
 419
 420 static unsigned long tty_color_instance_hash(Lisp_Color_Instance * c, int depth)
 421 {
 422         return LISP_HASH(COLOR_INSTANCE_TTY_SYMBOL(c));
 423 }
 424
 425 static int tty_valid_color_name_p(struct device *d, Lisp_Object color)
 426 {
 427         return (!NILP(Ffind_tty_color( color, wrap_object(d), Qt)));
 428 }
 429 \f
 430 static int
 431 tty_initialize_font_instance(Lisp_Font_Instance * f, Lisp_Object name,
 432                              Lisp_Object device, Error_behavior errb)
 433 {
 434         Bufbyte *str = XSTRING_DATA(name);
 435         Lisp_Object charset = Qnil;
 436
 437         if (strncmp((const char *)str, "normal", 6))
 438                 return 0;
 439         str += 6;
 440         if (*str) {
 441 #ifdef MULE
 442                 if (*str != '/')
 443                         return 0;
 444                 str++;
 445                 charset = Ffind_charset(intern((const char *)str));
 446                 if (NILP(charset))
 447                         return 0;
 448 #else
 449                 return 0;
 450 #endif
 451         }
 452
 453         /* Don't allocate the data until we're sure that we will succeed. */
 454         f->data = xnew(struct tty_font_instance_data);
 455         FONT_INSTANCE_TTY_CHARSET(f) = charset;
 456 #ifdef MULE
 457         if (CHARSETP(charset))
 458                 f->width = XCHARSET_COLUMNS(charset);
 459         else
 460 #endif
 461                 f->width = 1;
 462
 463         f->proportional_p = 0;
 464         f->ascent = f->height = 1;
 465         f->descent = 0;
 466
 467         return 1;
 468 }
 469
 470 static void tty_mark_font_instance(Lisp_Font_Instance * f)
 471 {
 472         mark_object(FONT_INSTANCE_TTY_CHARSET(f));
 473 }
 474
 475 static void
 476 tty_print_font_instance(Lisp_Font_Instance * f,
 477                         Lisp_Object printcharfun, int escapeflag)
 478 {
 479 }
 480
 481 static void tty_finalize_font_instance(Lisp_Font_Instance * f)
 482 {
 483         if (f->data)
 484                 xfree(f->data);
 485 }
 486
 487 static Lisp_Object tty_list_fonts(Lisp_Object pattern, Lisp_Object device)
 488 {
 489         return list1(build_string("normal"));
 490 }
 491
 492 #ifdef MULE
 493
 494 static int
 495 tty_font_spec_matches_charset(struct device *d, Lisp_Object charset,
 496                               const Bufbyte * nonreloc, Lisp_Object reloc,
 497                               Bytecount offset, Bytecount length)
 498 {
 499         const Bufbyte *the_nonreloc = nonreloc;
 500
 501         if (!the_nonreloc)
 502                 the_nonreloc = XSTRING_DATA(reloc);
 503         fixup_internal_substring(nonreloc, reloc, offset, &length);
 504
 505         assert(length>=0);
 506         if( length<0 ) {
 507                 abort();
 508                 return -1;
 509         }
 510
 511         the_nonreloc += offset;
 512
 513         if (UNBOUNDP(charset))
 514                 return !memchr(the_nonreloc, '/', length);
 515         the_nonreloc = (const Bufbyte *)memchr(the_nonreloc, '/', length);
 516         if (!the_nonreloc)
 517                 return 0;
 518         the_nonreloc++;
 519         {
 520                 Lisp_String *s = symbol_name(XSYMBOL(XCHARSET_NAME(charset)));
 521                 return !strcmp((const char *)the_nonreloc,
 522                                (const char *)string_data(s));
 523         }
 524 }
 525
 526 /* find a font spec that matches font spec FONT and also matches
 527    (the registry of) CHARSET. */
 528 static Lisp_Object
 529 tty_find_charset_font(Lisp_Object device, Lisp_Object font, Lisp_Object charset)
 530 {
 531         Bufbyte *fontname = XSTRING_DATA(font);
 532
 533         if (strchr((const char *)fontname, '/')) {
 534                 if (tty_font_spec_matches_charset(XDEVICE(device), charset, 0,
 535                                                   font, 0, -1))
 536                         return font;
 537                 return Qnil;
 538         }
 539
 540         if (UNBOUNDP(charset))
 541                 return font;
 542
 543         return concat3(font, build_string("/"),
 544                        Fsymbol_name(XCHARSET_NAME(charset)));
 545 }
 546
 547 #endif                          /* MULE */
 548 \f
 549 /************************************************************************/
 550 /*                            initialization                            */
 551 /************************************************************************/
 552
 553 void syms_of_objects_tty(void)
 554 {
 555         DEFSUBR(Fregister_tty_color_index);
 556         DEFSUBR(Ffind_tty_color);
 557         DEFSUBR(Ftty_registered_color_list);
 558         defsymbol(&Qx_nearest_color, "x-nearest-color");
 559 }
 560
 561 void console_type_create_objects_tty(void)
 562 {
 563         /* object methods */
 564         CONSOLE_HAS_METHOD(tty, initialize_color_instance);
 565         CONSOLE_HAS_METHOD(tty, mark_color_instance);
 566         CONSOLE_HAS_METHOD(tty, print_color_instance);
 567         CONSOLE_HAS_METHOD(tty, finalize_color_instance);
 568         CONSOLE_HAS_METHOD(tty, color_instance_equal);
 569         CONSOLE_HAS_METHOD(tty, color_instance_hash);
 570         CONSOLE_HAS_METHOD(tty, valid_color_name_p);
 571
 572         CONSOLE_HAS_METHOD(tty, initialize_font_instance);
 573         CONSOLE_HAS_METHOD(tty, mark_font_instance);
 574         CONSOLE_HAS_METHOD(tty, print_font_instance);
 575         CONSOLE_HAS_METHOD(tty, finalize_font_instance);
 576         CONSOLE_HAS_METHOD(tty, list_fonts);
 577 #ifdef MULE
 578         CONSOLE_HAS_METHOD(tty, font_spec_matches_charset);
 579         CONSOLE_HAS_METHOD(tty, find_charset_font);
 580 #endif
 581 }
 582
 583 void vars_of_objects_tty(void)
 584 {
 585         DEFVAR_LISP("term-color-alias-slist", &Vterm_color_alias_slist  /*
 586 Term => ( color => '(index bold) )
 587                                                                  */ );
 588         DEFVAR_LISP("term-color-map-slist", &Vterm_color_map_slist      /*
 589 Term => ( [r g b] => '(index bold) )
 590                                                                  */ );
 591         /*
 592         staticpro(&Vterm_color_alias_slist);
 593         staticpro(&Vterm_color_map_slist);
 594         */
 595         Vterm_color_alias_slist = Qnil;
 596         Vterm_color_map_slist = Qnil;
 597 }