1/* 2 * tkOldConfig.c -- 3 * 4 * This file contains the Tk_ConfigureWidget procedure. THIS FILE 5 * IS HERE FOR BACKWARD COMPATIBILITY; THE NEW CONFIGURATION 6 * PACKAGE SHOULD BE USED FOR NEW PROJECTS. 7 * 8 * Copyright (c) 1990-1994 The Regents of the University of California. 9 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 10 * 11 * See the file "license.terms" for information on usage and redistribution 12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tkOldConfig.c,v 1.12.2.3 2005/12/05 22:42:42 hobbs Exp $ 15 */ 16 17#include "tkPort.h" 18#include "tk.h" 19 20/* 21 * Values for "flags" field of Tk_ConfigSpec structures. Be sure 22 * to coordinate these values with those defined in tk.h 23 * (TK_CONFIG_COLOR_ONLY, etc.). There must not be overlap! 24 * 25 * INIT - Non-zero means (char *) things have been 26 * converted to Tk_Uid's. 27 */ 28 29#define INIT 0x20 30 31/* 32 * Forward declarations for procedures defined later in this file: 33 */ 34 35static int DoConfig _ANSI_ARGS_((Tcl_Interp *interp, 36 Tk_Window tkwin, Tk_ConfigSpec *specPtr, 37 Tk_Uid value, int valueIsUid, char *widgRec)); 38static Tk_ConfigSpec * FindConfigSpec _ANSI_ARGS_((Tcl_Interp *interp, 39 Tk_ConfigSpec *specs, CONST char *argvName, 40 int needFlags, int hateFlags)); 41static char * FormatConfigInfo _ANSI_ARGS_((Tcl_Interp *interp, 42 Tk_Window tkwin, Tk_ConfigSpec *specPtr, 43 char *widgRec)); 44static CONST char * FormatConfigValue _ANSI_ARGS_((Tcl_Interp *interp, 45 Tk_Window tkwin, Tk_ConfigSpec *specPtr, 46 char *widgRec, char *buffer, 47 Tcl_FreeProc **freeProcPtr)); 48static Tk_ConfigSpec * GetCachedSpecs _ANSI_ARGS_((Tcl_Interp *interp, 49 const Tk_ConfigSpec *staticSpecs)); 50static void DeleteSpecCacheTable _ANSI_ARGS_(( 51 ClientData clientData, Tcl_Interp *interp)); 52 53/* 54 *-------------------------------------------------------------- 55 * 56 * Tk_ConfigureWidget -- 57 * 58 * Process command-line options and database options to 59 * fill in fields of a widget record with resources and 60 * other parameters. 61 * 62 * Results: 63 * A standard Tcl return value. In case of an error, 64 * the interp's result will hold an error message. 65 * 66 * Side effects: 67 * The fields of widgRec get filled in with information from 68 * argc/argv and the option database. Old information in 69 * widgRec's fields gets recycled. A copy of the spec-table is 70 * taken with (some of) the char* *fields converted into Tk_Uid 71 * fields; this copy will be released when *the interpreter 72 * terminates. 73 * 74 *-------------------------------------------------------------- 75 */ 76 77int 78Tk_ConfigureWidget(interp, tkwin, origSpecs, argc, argv, widgRec, flags) 79 Tcl_Interp *interp; /* Interpreter for error reporting. */ 80 Tk_Window tkwin; /* Window containing widget (needed to 81 * set up X resources). */ 82 Tk_ConfigSpec *origSpecs; /* Describes legal options. */ 83 int argc; /* Number of elements in argv. */ 84 CONST char **argv; /* Command-line options. */ 85 char *widgRec; /* Record whose fields are to be 86 * modified. Values must be properly 87 * initialized. */ 88 int flags; /* Used to specify additional flags 89 * that must be present in config specs 90 * for them to be considered. Also, 91 * may have TK_CONFIG_ARGV_ONLY set. */ 92{ 93 register Tk_ConfigSpec *specs, *specPtr, *origSpecPtr; 94 Tk_Uid value; /* Value of option from database. */ 95 int needFlags; /* Specs must contain this set of flags 96 * or else they are not considered. */ 97 int hateFlags; /* If a spec contains any bits here, it's 98 * not considered. */ 99 100 if (tkwin == NULL) { 101 /* 102 * Either we're not really in Tk, or the main window was destroyed and 103 * we're on our way out of the application 104 */ 105 Tcl_AppendResult(interp, "NULL main window", (char *)NULL); 106 return TCL_ERROR; 107 } 108 109 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); 110 if (Tk_Depth(tkwin) <= 1) { 111 hateFlags = TK_CONFIG_COLOR_ONLY; 112 } else { 113 hateFlags = TK_CONFIG_MONO_ONLY; 114 } 115 116 /* 117 * Get the build of the config for this interpreter and reset any 118 * indication of changed options. 119 */ 120 121 specs = GetCachedSpecs(interp, origSpecs); 122 123 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { 124 specPtr->specFlags &= ~TK_CONFIG_OPTION_SPECIFIED; 125 } 126 127 /* 128 * Pass one: scan through all of the arguments, processing those 129 * that match entries in the specs. 130 */ 131 132 for ( ; argc > 0; argc -= 2, argv += 2) { 133 CONST char *arg; 134 135 if (flags & TK_CONFIG_OBJS) { 136 arg = Tcl_GetStringFromObj((Tcl_Obj *) *argv, NULL); 137 } else { 138 arg = *argv; 139 } 140 specPtr = FindConfigSpec(interp, specs, arg, needFlags, hateFlags); 141 if (specPtr == NULL) { 142 return TCL_ERROR; 143 } 144 145 /* 146 * Process the entry. 147 */ 148 149 if (argc < 2) { 150 Tcl_AppendResult(interp, "value for \"", arg, 151 "\" missing", (char *) NULL); 152 return TCL_ERROR; 153 } 154 if (flags & TK_CONFIG_OBJS) { 155 arg = Tcl_GetString((Tcl_Obj *) argv[1]); 156 } else { 157 arg = argv[1]; 158 } 159 if (DoConfig(interp, tkwin, specPtr, arg, 0, widgRec) != TCL_OK) { 160 char msg[100]; 161 162 sprintf(msg, "\n (processing \"%.40s\" option)", 163 specPtr->argvName); 164 Tcl_AddErrorInfo(interp, msg); 165 return TCL_ERROR; 166 } 167 specPtr->specFlags |= TK_CONFIG_OPTION_SPECIFIED; 168 } 169 170 /* 171 * Thread Unsafe! For compatibility through 8.4.x, we set the original 172 * specPtr flags to indicate changed options. This has been removed 173 * from 8.5. Switch to Tcl_Obj-based options instead. [Bug 749908] 174 */ 175 176 for (origSpecPtr = origSpecs, specPtr = specs; 177 specPtr->type != TK_CONFIG_END; origSpecPtr++, specPtr++) { 178 origSpecPtr->specFlags = specPtr->specFlags; 179 } 180 181 /* 182 * Pass two: scan through all of the specs again; if no 183 * command-line argument matched a spec, then check for info 184 * in the option database. If there was nothing in the 185 * database, then use the default. 186 */ 187 188 if (!(flags & TK_CONFIG_ARGV_ONLY)) { 189 for (specPtr=specs; specPtr->type!=TK_CONFIG_END; specPtr++) { 190 if ((specPtr->specFlags & TK_CONFIG_OPTION_SPECIFIED) 191 || (specPtr->argvName == NULL) 192 || (specPtr->type == TK_CONFIG_SYNONYM)) { 193 continue; 194 } 195 if (((specPtr->specFlags & needFlags) != needFlags) 196 || (specPtr->specFlags & hateFlags)) { 197 continue; 198 } 199 value = NULL; 200 if (specPtr->dbName != NULL) { 201 value = Tk_GetOption(tkwin, specPtr->dbName, specPtr->dbClass); 202 } 203 if (value != NULL) { 204 if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != 205 TCL_OK) { 206 char msg[200]; 207 208 sprintf(msg, "\n (%s \"%.50s\" in widget \"%.50s\")", 209 "database entry for", 210 specPtr->dbName, Tk_PathName(tkwin)); 211 Tcl_AddErrorInfo(interp, msg); 212 return TCL_ERROR; 213 } 214 } else { 215 if (specPtr->defValue != NULL) { 216 value = Tk_GetUid(specPtr->defValue); 217 } else { 218 value = NULL; 219 } 220 if ((value != NULL) && !(specPtr->specFlags 221 & TK_CONFIG_DONT_SET_DEFAULT)) { 222 if (DoConfig(interp, tkwin, specPtr, value, 1, widgRec) != 223 TCL_OK) { 224 char msg[200]; 225 226 sprintf(msg, 227 "\n (%s \"%.50s\" in widget \"%.50s\")", 228 "default value for", 229 specPtr->dbName, Tk_PathName(tkwin)); 230 Tcl_AddErrorInfo(interp, msg); 231 return TCL_ERROR; 232 } 233 } 234 } 235 } 236 } 237 238 return TCL_OK; 239} 240 241/* 242 *-------------------------------------------------------------- 243 * 244 * FindConfigSpec -- 245 * 246 * Search through a table of configuration specs, looking for 247 * one that matches a given argvName. 248 * 249 * Results: 250 * The return value is a pointer to the matching entry, or NULL 251 * if nothing matched. In that case an error message is left 252 * in the interp's result. 253 * 254 * Side effects: 255 * None. 256 * 257 *-------------------------------------------------------------- 258 */ 259 260static Tk_ConfigSpec * 261FindConfigSpec(interp, specs, argvName, needFlags, hateFlags) 262 Tcl_Interp *interp; /* Used for reporting errors. */ 263 Tk_ConfigSpec *specs; /* Pointer to table of configuration 264 * specifications for a widget. */ 265 CONST char *argvName; /* Name (suitable for use in a "config" 266 * command) identifying particular option. */ 267 int needFlags; /* Flags that must be present in matching 268 * entry. */ 269 int hateFlags; /* Flags that must NOT be present in 270 * matching entry. */ 271{ 272 register Tk_ConfigSpec *specPtr; 273 register char c; /* First character of current argument. */ 274 Tk_ConfigSpec *matchPtr; /* Matching spec, or NULL. */ 275 size_t length; 276 277 c = argvName[1]; 278 length = strlen(argvName); 279 matchPtr = NULL; 280 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { 281 if (specPtr->argvName == NULL) { 282 continue; 283 } 284 if ((specPtr->argvName[1] != c) 285 || (strncmp(specPtr->argvName, argvName, length) != 0)) { 286 continue; 287 } 288 if (((specPtr->specFlags & needFlags) != needFlags) 289 || (specPtr->specFlags & hateFlags)) { 290 continue; 291 } 292 if (specPtr->argvName[length] == 0) { 293 matchPtr = specPtr; 294 goto gotMatch; 295 } 296 if (matchPtr != NULL) { 297 Tcl_AppendResult(interp, "ambiguous option \"", argvName, 298 "\"", (char *) NULL); 299 return (Tk_ConfigSpec *) NULL; 300 } 301 matchPtr = specPtr; 302 } 303 304 if (matchPtr == NULL) { 305 Tcl_AppendResult(interp, "unknown option \"", argvName, 306 "\"", (char *) NULL); 307 return (Tk_ConfigSpec *) NULL; 308 } 309 310 /* 311 * Found a matching entry. If it's a synonym, then find the 312 * entry that it's a synonym for. 313 */ 314 315 gotMatch: 316 specPtr = matchPtr; 317 if (specPtr->type == TK_CONFIG_SYNONYM) { 318 for (specPtr = specs; ; specPtr++) { 319 if (specPtr->type == TK_CONFIG_END) { 320 Tcl_AppendResult(interp, 321 "couldn't find synonym for option \"", 322 argvName, "\"", (char *) NULL); 323 return (Tk_ConfigSpec *) NULL; 324 } 325 if ((specPtr->dbName == matchPtr->dbName) 326 && (specPtr->type != TK_CONFIG_SYNONYM) 327 && ((specPtr->specFlags & needFlags) == needFlags) 328 && !(specPtr->specFlags & hateFlags)) { 329 break; 330 } 331 } 332 } 333 return specPtr; 334} 335 336/* 337 *-------------------------------------------------------------- 338 * 339 * DoConfig -- 340 * 341 * This procedure applies a single configuration option 342 * to a widget record. 343 * 344 * Results: 345 * A standard Tcl return value. 346 * 347 * Side effects: 348 * WidgRec is modified as indicated by specPtr and value. 349 * The old value is recycled, if that is appropriate for 350 * the value type. 351 * 352 *-------------------------------------------------------------- 353 */ 354 355static int 356DoConfig(interp, tkwin, specPtr, value, valueIsUid, widgRec) 357 Tcl_Interp *interp; /* Interpreter for error reporting. */ 358 Tk_Window tkwin; /* Window containing widget (needed to 359 * set up X resources). */ 360 Tk_ConfigSpec *specPtr; /* Specifier to apply. */ 361 Tk_Uid value; /* Value to use to fill in widgRec. */ 362 int valueIsUid; /* Non-zero means value is a Tk_Uid; 363 * zero means it's an ordinary string. */ 364 char *widgRec; /* Record whose fields are to be 365 * modified. Values must be properly 366 * initialized. */ 367{ 368 char *ptr; 369 Tk_Uid uid; 370 int nullValue; 371 372 nullValue = 0; 373 if ((*value == 0) && (specPtr->specFlags & TK_CONFIG_NULL_OK)) { 374 nullValue = 1; 375 } 376 377 do { 378 ptr = widgRec + specPtr->offset; 379 switch (specPtr->type) { 380 case TK_CONFIG_BOOLEAN: 381 if (Tcl_GetBoolean(interp, value, (int *) ptr) != TCL_OK) { 382 return TCL_ERROR; 383 } 384 break; 385 case TK_CONFIG_INT: 386 if (Tcl_GetInt(interp, value, (int *) ptr) != TCL_OK) { 387 return TCL_ERROR; 388 } 389 break; 390 case TK_CONFIG_DOUBLE: 391 if (Tcl_GetDouble(interp, value, (double *) ptr) != TCL_OK) { 392 return TCL_ERROR; 393 } 394 break; 395 case TK_CONFIG_STRING: { 396 char *old, *new; 397 398 if (nullValue) { 399 new = NULL; 400 } else { 401 new = (char *) ckalloc((unsigned) (strlen(value) + 1)); 402 strcpy(new, value); 403 } 404 old = *((char **) ptr); 405 if (old != NULL) { 406 ckfree(old); 407 } 408 *((char **) ptr) = new; 409 break; 410 } 411 case TK_CONFIG_UID: 412 if (nullValue) { 413 *((Tk_Uid *) ptr) = NULL; 414 } else { 415 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 416 *((Tk_Uid *) ptr) = uid; 417 } 418 break; 419 case TK_CONFIG_COLOR: { 420 XColor *newPtr, *oldPtr; 421 422 if (nullValue) { 423 newPtr = NULL; 424 } else { 425 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 426 newPtr = Tk_GetColor(interp, tkwin, uid); 427 if (newPtr == NULL) { 428 return TCL_ERROR; 429 } 430 } 431 oldPtr = *((XColor **) ptr); 432 if (oldPtr != NULL) { 433 Tk_FreeColor(oldPtr); 434 } 435 *((XColor **) ptr) = newPtr; 436 break; 437 } 438 case TK_CONFIG_FONT: { 439 Tk_Font new; 440 441 if (nullValue) { 442 new = NULL; 443 } else { 444 new = Tk_GetFont(interp, tkwin, value); 445 if (new == NULL) { 446 return TCL_ERROR; 447 } 448 } 449 Tk_FreeFont(*((Tk_Font *) ptr)); 450 *((Tk_Font *) ptr) = new; 451 break; 452 } 453 case TK_CONFIG_BITMAP: { 454 Pixmap new, old; 455 456 if (nullValue) { 457 new = None; 458 } else { 459 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 460 new = Tk_GetBitmap(interp, tkwin, uid); 461 if (new == None) { 462 return TCL_ERROR; 463 } 464 } 465 old = *((Pixmap *) ptr); 466 if (old != None) { 467 Tk_FreeBitmap(Tk_Display(tkwin), old); 468 } 469 *((Pixmap *) ptr) = new; 470 break; 471 } 472 case TK_CONFIG_BORDER: { 473 Tk_3DBorder new, old; 474 475 if (nullValue) { 476 new = NULL; 477 } else { 478 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 479 new = Tk_Get3DBorder(interp, tkwin, uid); 480 if (new == NULL) { 481 return TCL_ERROR; 482 } 483 } 484 old = *((Tk_3DBorder *) ptr); 485 if (old != NULL) { 486 Tk_Free3DBorder(old); 487 } 488 *((Tk_3DBorder *) ptr) = new; 489 break; 490 } 491 case TK_CONFIG_RELIEF: 492 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 493 if (Tk_GetRelief(interp, uid, (int *) ptr) != TCL_OK) { 494 return TCL_ERROR; 495 } 496 break; 497 case TK_CONFIG_CURSOR: 498 case TK_CONFIG_ACTIVE_CURSOR: { 499 Tk_Cursor new, old; 500 501 if (nullValue) { 502 new = None; 503 } else { 504 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 505 new = Tk_GetCursor(interp, tkwin, uid); 506 if (new == None) { 507 return TCL_ERROR; 508 } 509 } 510 old = *((Tk_Cursor *) ptr); 511 if (old != None) { 512 Tk_FreeCursor(Tk_Display(tkwin), old); 513 } 514 *((Tk_Cursor *) ptr) = new; 515 if (specPtr->type == TK_CONFIG_ACTIVE_CURSOR) { 516 Tk_DefineCursor(tkwin, new); 517 } 518 break; 519 } 520 case TK_CONFIG_JUSTIFY: 521 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 522 if (Tk_GetJustify(interp, uid, (Tk_Justify *) ptr) != TCL_OK) { 523 return TCL_ERROR; 524 } 525 break; 526 case TK_CONFIG_ANCHOR: 527 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 528 if (Tk_GetAnchor(interp, uid, (Tk_Anchor *) ptr) != TCL_OK) { 529 return TCL_ERROR; 530 } 531 break; 532 case TK_CONFIG_CAP_STYLE: 533 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 534 if (Tk_GetCapStyle(interp, uid, (int *) ptr) != TCL_OK) { 535 return TCL_ERROR; 536 } 537 break; 538 case TK_CONFIG_JOIN_STYLE: 539 uid = valueIsUid ? (Tk_Uid) value : Tk_GetUid(value); 540 if (Tk_GetJoinStyle(interp, uid, (int *) ptr) != TCL_OK) { 541 return TCL_ERROR; 542 } 543 break; 544 case TK_CONFIG_PIXELS: 545 if (Tk_GetPixels(interp, tkwin, value, (int *) ptr) 546 != TCL_OK) { 547 return TCL_ERROR; 548 } 549 break; 550 case TK_CONFIG_MM: 551 if (Tk_GetScreenMM(interp, tkwin, value, (double *) ptr) 552 != TCL_OK) { 553 return TCL_ERROR; 554 } 555 break; 556 case TK_CONFIG_WINDOW: { 557 Tk_Window tkwin2; 558 559 if (nullValue) { 560 tkwin2 = NULL; 561 } else { 562 tkwin2 = Tk_NameToWindow(interp, value, tkwin); 563 if (tkwin2 == NULL) { 564 return TCL_ERROR; 565 } 566 } 567 *((Tk_Window *) ptr) = tkwin2; 568 break; 569 } 570 case TK_CONFIG_CUSTOM: 571 if ((*specPtr->customPtr->parseProc)( 572 specPtr->customPtr->clientData, interp, tkwin, 573 value, widgRec, specPtr->offset) != TCL_OK) { 574 return TCL_ERROR; 575 } 576 break; 577 default: { 578 char buf[64 + TCL_INTEGER_SPACE]; 579 580 sprintf(buf, "bad config table: unknown type %d", 581 specPtr->type); 582 Tcl_SetResult(interp, buf, TCL_VOLATILE); 583 return TCL_ERROR; 584 } 585 } 586 specPtr++; 587 } while ((specPtr->argvName == NULL) && (specPtr->type != TK_CONFIG_END)); 588 return TCL_OK; 589} 590 591/* 592 *-------------------------------------------------------------- 593 * 594 * Tk_ConfigureInfo -- 595 * 596 * Return information about the configuration options 597 * for a window, and their current values. 598 * 599 * Results: 600 * Always returns TCL_OK. The interp's result will be modified 601 * hold a description of either a single configuration option 602 * available for "widgRec" via "specs", or all the configuration 603 * options available. In the "all" case, the result will 604 * available for "widgRec" via "specs". The result will 605 * be a list, each of whose entries describes one option. 606 * Each entry will itself be a list containing the option's 607 * name for use on command lines, database name, database 608 * class, default value, and current value (empty string 609 * if none). For options that are synonyms, the list will 610 * contain only two values: name and synonym name. If the 611 * "name" argument is non-NULL, then the only information 612 * returned is that for the named argument (i.e. the corresponding 613 * entry in the overall list is returned). 614 * 615 * Side effects: 616 * None. 617 * 618 *-------------------------------------------------------------- 619 */ 620 621int 622Tk_ConfigureInfo(interp, tkwin, specs, widgRec, argvName, flags) 623 Tcl_Interp *interp; /* Interpreter for error reporting. */ 624 Tk_Window tkwin; /* Window corresponding to widgRec. */ 625 Tk_ConfigSpec *specs; /* Describes legal options. */ 626 char *widgRec; /* Record whose fields contain current 627 * values for options. */ 628 CONST char *argvName; /* If non-NULL, indicates a single option 629 * whose info is to be returned. Otherwise 630 * info is returned for all options. */ 631 int flags; /* Used to specify additional flags 632 * that must be present in config specs 633 * for them to be considered. */ 634{ 635 register Tk_ConfigSpec *specPtr; 636 int needFlags, hateFlags; 637 char *list; 638 char *leader = "{"; 639 640 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); 641 if (Tk_Depth(tkwin) <= 1) { 642 hateFlags = TK_CONFIG_COLOR_ONLY; 643 } else { 644 hateFlags = TK_CONFIG_MONO_ONLY; 645 } 646 647 /* 648 * Get the build of the config for this interpreter. 649 */ 650 651 specs = GetCachedSpecs(interp, specs); 652 653 /* 654 * If information is only wanted for a single configuration 655 * spec, then handle that one spec specially. 656 */ 657 658 Tcl_SetResult(interp, (char *) NULL, TCL_STATIC); 659 if (argvName != NULL) { 660 specPtr = FindConfigSpec(interp, specs, argvName, needFlags,hateFlags); 661 if (specPtr == NULL) { 662 return TCL_ERROR; 663 } 664 Tcl_SetResult(interp, 665 FormatConfigInfo(interp, tkwin, specPtr, widgRec), 666 TCL_DYNAMIC); 667 return TCL_OK; 668 } 669 670 /* 671 * Loop through all the specs, creating a big list with all 672 * their information. 673 */ 674 675 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { 676 if ((argvName != NULL) && (specPtr->argvName != argvName)) { 677 continue; 678 } 679 if (((specPtr->specFlags & needFlags) != needFlags) 680 || (specPtr->specFlags & hateFlags)) { 681 continue; 682 } 683 if (specPtr->argvName == NULL) { 684 continue; 685 } 686 list = FormatConfigInfo(interp, tkwin, specPtr, widgRec); 687 Tcl_AppendResult(interp, leader, list, "}", (char *) NULL); 688 ckfree(list); 689 leader = " {"; 690 } 691 return TCL_OK; 692} 693 694/* 695 *-------------------------------------------------------------- 696 * 697 * FormatConfigInfo -- 698 * 699 * Create a valid Tcl list holding the configuration information 700 * for a single configuration option. 701 * 702 * Results: 703 * A Tcl list, dynamically allocated. The caller is expected to 704 * arrange for this list to be freed eventually. 705 * 706 * Side effects: 707 * Memory is allocated. 708 * 709 *-------------------------------------------------------------- 710 */ 711 712static char * 713FormatConfigInfo(interp, tkwin, specPtr, widgRec) 714 Tcl_Interp *interp; /* Interpreter to use for things 715 * like floating-point precision. */ 716 Tk_Window tkwin; /* Window corresponding to widget. */ 717 register Tk_ConfigSpec *specPtr; /* Pointer to information describing 718 * option. */ 719 char *widgRec; /* Pointer to record holding current 720 * values of info for widget. */ 721{ 722 CONST char *argv[6]; 723 char *result; 724 char buffer[200]; 725 Tcl_FreeProc *freeProc = (Tcl_FreeProc *) NULL; 726 727 argv[0] = specPtr->argvName; 728 argv[1] = specPtr->dbName; 729 argv[2] = specPtr->dbClass; 730 argv[3] = specPtr->defValue; 731 if (specPtr->type == TK_CONFIG_SYNONYM) { 732 return Tcl_Merge(2, argv); 733 } 734 argv[4] = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, 735 &freeProc); 736 if (argv[1] == NULL) { 737 argv[1] = ""; 738 } 739 if (argv[2] == NULL) { 740 argv[2] = ""; 741 } 742 if (argv[3] == NULL) { 743 argv[3] = ""; 744 } 745 if (argv[4] == NULL) { 746 argv[4] = ""; 747 } 748 result = Tcl_Merge(5, argv); 749 if (freeProc != NULL) { 750 if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { 751 ckfree((char *)argv[4]); 752 } else { 753 (*freeProc)((char *)argv[4]); 754 } 755 } 756 return result; 757} 758 759/* 760 *---------------------------------------------------------------------- 761 * 762 * FormatConfigValue -- 763 * 764 * This procedure formats the current value of a configuration 765 * option. 766 * 767 * Results: 768 * The return value is the formatted value of the option given 769 * by specPtr and widgRec. If the value is static, so that it 770 * need not be freed, *freeProcPtr will be set to NULL; otherwise 771 * *freeProcPtr will be set to the address of a procedure to 772 * free the result, and the caller must invoke this procedure 773 * when it is finished with the result. 774 * 775 * Side effects: 776 * None. 777 * 778 *---------------------------------------------------------------------- 779 */ 780 781static CONST char * 782FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, freeProcPtr) 783 Tcl_Interp *interp; /* Interpreter for use in real conversions. */ 784 Tk_Window tkwin; /* Window corresponding to widget. */ 785 Tk_ConfigSpec *specPtr; /* Pointer to information describing option. 786 * Must not point to a synonym option. */ 787 char *widgRec; /* Pointer to record holding current 788 * values of info for widget. */ 789 char *buffer; /* Static buffer to use for small values. 790 * Must have at least 200 bytes of storage. */ 791 Tcl_FreeProc **freeProcPtr; /* Pointer to word to fill in with address 792 * of procedure to free the result, or NULL 793 * if result is static. */ 794{ 795 CONST char *ptr, *result; 796 797 *freeProcPtr = NULL; 798 ptr = widgRec + specPtr->offset; 799 result = ""; 800 switch (specPtr->type) { 801 case TK_CONFIG_BOOLEAN: 802 if (*((int *) ptr) == 0) { 803 result = "0"; 804 } else { 805 result = "1"; 806 } 807 break; 808 case TK_CONFIG_INT: 809 sprintf(buffer, "%d", *((int *) ptr)); 810 result = buffer; 811 break; 812 case TK_CONFIG_DOUBLE: 813 Tcl_PrintDouble(interp, *((double *) ptr), buffer); 814 result = buffer; 815 break; 816 case TK_CONFIG_STRING: 817 result = (*(char **) ptr); 818 if (result == NULL) { 819 result = ""; 820 } 821 break; 822 case TK_CONFIG_UID: { 823 Tk_Uid uid = *((Tk_Uid *) ptr); 824 if (uid != NULL) { 825 result = uid; 826 } 827 break; 828 } 829 case TK_CONFIG_COLOR: { 830 XColor *colorPtr = *((XColor **) ptr); 831 if (colorPtr != NULL) { 832 result = Tk_NameOfColor(colorPtr); 833 } 834 break; 835 } 836 case TK_CONFIG_FONT: { 837 Tk_Font tkfont = *((Tk_Font *) ptr); 838 if (tkfont != NULL) { 839 result = Tk_NameOfFont(tkfont); 840 } 841 break; 842 } 843 case TK_CONFIG_BITMAP: { 844 Pixmap pixmap = *((Pixmap *) ptr); 845 if (pixmap != None) { 846 result = Tk_NameOfBitmap(Tk_Display(tkwin), pixmap); 847 } 848 break; 849 } 850 case TK_CONFIG_BORDER: { 851 Tk_3DBorder border = *((Tk_3DBorder *) ptr); 852 if (border != NULL) { 853 result = Tk_NameOf3DBorder(border); 854 } 855 break; 856 } 857 case TK_CONFIG_RELIEF: 858 result = Tk_NameOfRelief(*((int *) ptr)); 859 break; 860 case TK_CONFIG_CURSOR: 861 case TK_CONFIG_ACTIVE_CURSOR: { 862 Tk_Cursor cursor = *((Tk_Cursor *) ptr); 863 if (cursor != None) { 864 result = Tk_NameOfCursor(Tk_Display(tkwin), cursor); 865 } 866 break; 867 } 868 case TK_CONFIG_JUSTIFY: 869 result = Tk_NameOfJustify(*((Tk_Justify *) ptr)); 870 break; 871 case TK_CONFIG_ANCHOR: 872 result = Tk_NameOfAnchor(*((Tk_Anchor *) ptr)); 873 break; 874 case TK_CONFIG_CAP_STYLE: 875 result = Tk_NameOfCapStyle(*((int *) ptr)); 876 break; 877 case TK_CONFIG_JOIN_STYLE: 878 result = Tk_NameOfJoinStyle(*((int *) ptr)); 879 break; 880 case TK_CONFIG_PIXELS: 881 sprintf(buffer, "%d", *((int *) ptr)); 882 result = buffer; 883 break; 884 case TK_CONFIG_MM: 885 Tcl_PrintDouble(interp, *((double *) ptr), buffer); 886 result = buffer; 887 break; 888 case TK_CONFIG_WINDOW: { 889 Tk_Window tkwin; 890 891 tkwin = *((Tk_Window *) ptr); 892 if (tkwin != NULL) { 893 result = Tk_PathName(tkwin); 894 } 895 break; 896 } 897 case TK_CONFIG_CUSTOM: 898 result = (*specPtr->customPtr->printProc)( 899 specPtr->customPtr->clientData, tkwin, widgRec, 900 specPtr->offset, freeProcPtr); 901 break; 902 default: 903 result = "?? unknown type ??"; 904 } 905 return result; 906} 907 908/* 909 *---------------------------------------------------------------------- 910 * 911 * Tk_ConfigureValue -- 912 * 913 * This procedure returns the current value of a configuration 914 * option for a widget. 915 * 916 * Results: 917 * The return value is a standard Tcl completion code (TCL_OK or 918 * TCL_ERROR). The interp's result will be set to hold either the value 919 * of the option given by argvName (if TCL_OK is returned) or 920 * an error message (if TCL_ERROR is returned). 921 * 922 * Side effects: 923 * None. 924 * 925 *---------------------------------------------------------------------- 926 */ 927 928int 929Tk_ConfigureValue(interp, tkwin, specs, widgRec, argvName, flags) 930 Tcl_Interp *interp; /* Interpreter for error reporting. */ 931 Tk_Window tkwin; /* Window corresponding to widgRec. */ 932 Tk_ConfigSpec *specs; /* Describes legal options. */ 933 char *widgRec; /* Record whose fields contain current 934 * values for options. */ 935 CONST char *argvName; /* Gives the command-line name for the 936 * option whose value is to be returned. */ 937 int flags; /* Used to specify additional flags 938 * that must be present in config specs 939 * for them to be considered. */ 940{ 941 Tk_ConfigSpec *specPtr; 942 int needFlags, hateFlags; 943 Tcl_FreeProc *freeProc; 944 CONST char *result; 945 char buffer[200]; 946 947 needFlags = flags & ~(TK_CONFIG_USER_BIT - 1); 948 if (Tk_Depth(tkwin) <= 1) { 949 hateFlags = TK_CONFIG_COLOR_ONLY; 950 } else { 951 hateFlags = TK_CONFIG_MONO_ONLY; 952 } 953 954 /* 955 * Get the build of the config for this interpreter. 956 */ 957 958 specs = GetCachedSpecs(interp, specs); 959 960 specPtr = FindConfigSpec(interp, specs, argvName, needFlags, hateFlags); 961 if (specPtr == NULL) { 962 return TCL_ERROR; 963 } 964 result = FormatConfigValue(interp, tkwin, specPtr, widgRec, buffer, &freeProc); 965 Tcl_SetResult(interp, (char *) result, TCL_VOLATILE); 966 if (freeProc != NULL) { 967 if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { 968 ckfree((char *)result); 969 } else { 970 (*freeProc)((char *)result); 971 } 972 } 973 return TCL_OK; 974} 975 976/* 977 *---------------------------------------------------------------------- 978 * 979 * Tk_FreeOptions -- 980 * 981 * Free up all resources associated with configuration options. 982 * 983 * Results: 984 * None. 985 * 986 * Side effects: 987 * Any resource in widgRec that is controlled by a configuration 988 * option (e.g. a Tk_3DBorder or XColor) is freed in the appropriate 989 * fashion. 990 * 991 *---------------------------------------------------------------------- 992 */ 993 994 /* ARGSUSED */ 995void 996Tk_FreeOptions(specs, widgRec, display, needFlags) 997 Tk_ConfigSpec *specs; /* Describes legal options. */ 998 char *widgRec; /* Record whose fields contain current 999 * values for options. */ 1000 Display *display; /* X display; needed for freeing some 1001 * resources. */ 1002 int needFlags; /* Used to specify additional flags 1003 * that must be present in config specs 1004 * for them to be considered. */ 1005{ 1006 register Tk_ConfigSpec *specPtr; 1007 char *ptr; 1008 1009 for (specPtr = specs; specPtr->type != TK_CONFIG_END; specPtr++) { 1010 if ((specPtr->specFlags & needFlags) != needFlags) { 1011 continue; 1012 } 1013 ptr = widgRec + specPtr->offset; 1014 switch (specPtr->type) { 1015 case TK_CONFIG_STRING: 1016 if (*((char **) ptr) != NULL) { 1017 ckfree(*((char **) ptr)); 1018 *((char **) ptr) = NULL; 1019 } 1020 break; 1021 case TK_CONFIG_COLOR: 1022 if (*((XColor **) ptr) != NULL) { 1023 Tk_FreeColor(*((XColor **) ptr)); 1024 *((XColor **) ptr) = NULL; 1025 } 1026 break; 1027 case TK_CONFIG_FONT: 1028 Tk_FreeFont(*((Tk_Font *) ptr)); 1029 *((Tk_Font *) ptr) = NULL; 1030 break; 1031 case TK_CONFIG_BITMAP: 1032 if (*((Pixmap *) ptr) != None) { 1033 Tk_FreeBitmap(display, *((Pixmap *) ptr)); 1034 *((Pixmap *) ptr) = None; 1035 } 1036 break; 1037 case TK_CONFIG_BORDER: 1038 if (*((Tk_3DBorder *) ptr) != NULL) { 1039 Tk_Free3DBorder(*((Tk_3DBorder *) ptr)); 1040 *((Tk_3DBorder *) ptr) = NULL; 1041 } 1042 break; 1043 case TK_CONFIG_CURSOR: 1044 case TK_CONFIG_ACTIVE_CURSOR: 1045 if (*((Tk_Cursor *) ptr) != None) { 1046 Tk_FreeCursor(display, *((Tk_Cursor *) ptr)); 1047 *((Tk_Cursor *) ptr) = None; 1048 } 1049 } 1050 } 1051} 1052 1053/* 1054 *-------------------------------------------------------------- 1055 * 1056 * GetCachedSpecs -- 1057 * 1058 *Returns a writable per-interpreter (and hence thread-local) copy of 1059 *the given spec-table with (some of) the char* fields converted into 1060 *Tk_Uid fields; this copy will be released when the interpreter 1061 *terminates (during AssocData cleanup). 1062 * 1063 * Results: 1064 *A pointer to the copied table. 1065 * 1066 * Notes: 1067 *The conversion to Tk_Uid is only done the first time, when the table 1068 *copy is taken. After that, the table is assumed to have Tk_Uids where 1069 *they are needed. The time of deletion of the caches isn't very 1070 *important unless you've got a lot of code that uses Tk_ConfigureWidget 1071 *(or *Info or *Value} when the interpreter is being deleted. 1072 * 1073 *-------------------------------------------------------------- 1074 */ 1075 1076static Tk_ConfigSpec * 1077GetCachedSpecs(interp, staticSpecs) 1078 Tcl_Interp *interp; /* Interpreter in which to store the cache. */ 1079 const Tk_ConfigSpec *staticSpecs; 1080 /* Value to cache a copy of; it is also used 1081 * as a key into the cache. */ 1082{ 1083 Tk_ConfigSpec *cachedSpecs; 1084 Tcl_HashTable *specCacheTablePtr; 1085 Tcl_HashEntry *entryPtr; 1086 int isNew; 1087 1088 /* 1089 * Get (or allocate if it doesn't exist) the hash table that the writable 1090 * copies of the widget specs are stored in. In effect, this is 1091 * self-initializing code. 1092 */ 1093 1094 specCacheTablePtr = (Tcl_HashTable *) 1095 Tcl_GetAssocData(interp, "tkConfigSpec.threadTable", NULL); 1096 if (specCacheTablePtr == NULL) { 1097 specCacheTablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); 1098 Tcl_InitHashTable(specCacheTablePtr, TCL_ONE_WORD_KEYS); 1099 Tcl_SetAssocData(interp, "tkConfigSpec.threadTable", 1100 DeleteSpecCacheTable, (ClientData) specCacheTablePtr); 1101 } 1102 1103 /* 1104 * Look up or create the hash entry that the constant specs are mapped to, 1105 * which will have the writable specs as its associated value. 1106 */ 1107 1108 entryPtr = Tcl_CreateHashEntry(specCacheTablePtr, (char *) staticSpecs, 1109 &isNew); 1110 if (isNew) { 1111 unsigned int entrySpace = sizeof(Tk_ConfigSpec); 1112 const Tk_ConfigSpec *staticSpecPtr; 1113 Tk_ConfigSpec *specPtr; 1114 1115 /* 1116 * OK, no working copy in this interpreter so copy. Need to work out 1117 * how much space to allocate first. 1118 */ 1119 1120 for (staticSpecPtr=staticSpecs; staticSpecPtr->type!=TK_CONFIG_END; 1121 staticSpecPtr++) { 1122 entrySpace += sizeof(Tk_ConfigSpec); 1123 } 1124 1125 /* 1126 * Now allocate our working copy's space and copy over the contents 1127 * from the master copy. 1128 */ 1129 1130 cachedSpecs = (Tk_ConfigSpec *) ckalloc(entrySpace); 1131 memcpy((void *) cachedSpecs, (void *) staticSpecs, entrySpace); 1132 Tcl_SetHashValue(entryPtr, (ClientData) cachedSpecs); 1133 1134 /* 1135 * Finally, go through and replace database names, database classes 1136 * and default values with Tk_Uids. This is the bit that has to be 1137 * per-thread. 1138 */ 1139 1140 for (specPtr=cachedSpecs; specPtr->type!=TK_CONFIG_END; specPtr++) { 1141 if (specPtr->argvName != NULL) { 1142 if (specPtr->dbName != NULL) { 1143 specPtr->dbName = Tk_GetUid(specPtr->dbName); 1144 } 1145 if (specPtr->dbClass != NULL) { 1146 specPtr->dbClass = Tk_GetUid(specPtr->dbClass); 1147 } 1148 if (specPtr->defValue != NULL) { 1149 specPtr->defValue = Tk_GetUid(specPtr->defValue); 1150 } 1151 } 1152 } 1153 } else { 1154 cachedSpecs = (Tk_ConfigSpec *) Tcl_GetHashValue(entryPtr); 1155 } 1156 1157 return cachedSpecs; 1158} 1159 1160/* 1161 *-------------------------------------------------------------- 1162 * 1163 * DeleteSpecCacheTable -- 1164 * 1165 * Delete the per-interpreter copy of all the Tk_ConfigSpec tables which 1166 * were stored in the interpreter's assoc-data store. 1167 * 1168 * Results: 1169 * None 1170 * 1171 * Side effects: 1172 * None 1173 * 1174 *-------------------------------------------------------------- 1175 */ 1176 1177static void 1178DeleteSpecCacheTable(clientData, interp) 1179 ClientData clientData; 1180 Tcl_Interp *interp; 1181{ 1182 Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; 1183 Tcl_HashEntry *entryPtr; 1184 Tcl_HashSearch search; 1185 1186 for (entryPtr = Tcl_FirstHashEntry(tablePtr,&search); entryPtr != NULL; 1187 entryPtr = Tcl_NextHashEntry(&search)) { 1188 /* 1189 * Someone else deallocates the Tk_Uids themselves. 1190 */ 1191 1192 ckfree((char *) Tcl_GetHashValue(entryPtr)); 1193 } 1194 Tcl_DeleteHashTable(tablePtr); 1195 ckfree((char *) tablePtr); 1196} 1197