util/src/TclTk/tk8.6.12/generic/tkOldConfig.c

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