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

   1 /*
   2  * tkTest.c --
   3  *
   4  *      This file contains C command functions for a bunch of additional Tcl
   5  *      commands that are used for testing out Tcl's C interfaces. These
   6  *      commands are not normally included in Tcl applications; they're only
   7  *      used for testing.
   8  *
   9  * Copyright (c) 1993-1994 The Regents of the University of California.
  10  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
  11  * Copyright (c) 1998-1999 by Scriptics Corporation.
  12  *
  13  * See the file "license.terms" for information on usage and redistribution of
  14  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15  */
  16
  17 #undef STATIC_BUILD
  18 #ifndef USE_TCL_STUBS
  19 #   define USE_TCL_STUBS
  20 #endif
  21 #ifndef USE_TK_STUBS
  22 #   define USE_TK_STUBS
  23 #endif
  24 #include "tkInt.h"
  25 #include "tkText.h"
  26
  27 #ifdef _WIN32
  28 #include "tkWinInt.h"
  29 #endif
  30
  31 #if defined(MAC_OSX_TK)
  32 #include "tkMacOSXInt.h"
  33 #include "tkScrollbar.h"
  34 #define LOG_DISPLAY(drawable) TkTestLogDisplay(drawable)
  35 #else
  36 #define LOG_DISPLAY(drawable) 1
  37 #endif
  38
  39 #ifdef __UNIX__
  40 #include "tkUnixInt.h"
  41 #endif
  42
  43 /*
  44  * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
  45  * Tcltest_Init declaration is in the source file itself, which is only
  46  * accessed when we are building a library.
  47  */
  48
  49 #undef TCL_STORAGE_CLASS
  50 #define TCL_STORAGE_CLASS DLLEXPORT
  51 EXTERN int              Tktest_Init(Tcl_Interp *interp);
  52 /*
  53  * The following data structure represents the model for a test image:
  54  */
  55
  56 typedef struct TImageModel {
  57     Tk_ImageModel model;        /* Tk's token for image model. */
  58     Tcl_Interp *interp;         /* Interpreter for application. */
  59     int width, height;          /* Dimensions of image. */
  60     char *imageName;            /* Name of image (malloc-ed). */
  61     char *varName;              /* Name of variable in which to log events for
  62                                  * image (malloc-ed). */
  63 } TImageModel;
  64
  65 /*
  66  * The following data structure represents a particular use of a particular
  67  * test image.
  68  */
  69
  70 typedef struct TImageInstance {
  71     TImageModel *modelPtr;      /* Pointer to model for image. */
  72     XColor *fg;                 /* Foreground color for drawing in image. */
  73     GC gc;                      /* Graphics context for drawing in image. */
  74     Bool displayFailed;         /* macOS display attempted out of drawRect. */
  75     char buffer[200 + TCL_INTEGER_SPACE * 6]; /* message to log on display. */
  76 } TImageInstance;
  77
  78 /*
  79  * The type record for test images:
  80  */
  81
  82 static int              ImageCreate(Tcl_Interp *interp,
  83                             const char *name, int argc, Tcl_Obj *const objv[],
  84                             const Tk_ImageType *typePtr, Tk_ImageModel model,
  85                             ClientData *clientDataPtr);
  86 static ClientData       ImageGet(Tk_Window tkwin, ClientData clientData);
  87 static void             ImageDisplay(ClientData clientData,
  88                             Display *display, Drawable drawable,
  89                             int imageX, int imageY, int width,
  90                             int height, int drawableX,
  91                             int drawableY);
  92 static void             ImageFree(ClientData clientData, Display *display);
  93 static void             ImageDelete(ClientData clientData);
  94
  95 static Tk_ImageType imageType = {
  96     "test",                     /* name */
  97     ImageCreate,                /* createProc */
  98     ImageGet,                   /* getProc */
  99     ImageDisplay,               /* displayProc */
 100     ImageFree,                  /* freeProc */
 101     ImageDelete,                /* deleteProc */
 102     NULL,                       /* postscriptPtr */
 103     NULL,                       /* nextPtr */
 104     NULL
 105 };
 106
 107 /*
 108  * One of the following structures describes each of the interpreters created
 109  * by the "testnewapp" command. This information is used by the
 110  * "testdeleteinterps" command to destroy all of those interpreters.
 111  */
 112
 113 typedef struct NewApp {
 114     Tcl_Interp *interp;         /* Token for interpreter. */
 115     struct NewApp *nextPtr;     /* Next in list of new interpreters. */
 116 } NewApp;
 117
 118 static NewApp *newAppPtr = NULL;/* First in list of all new interpreters. */
 119
 120 /*
 121  * Header for trivial configuration command items.
 122  */
 123
 124 #define ODD     TK_CONFIG_USER_BIT
 125 #define EVEN    (TK_CONFIG_USER_BIT << 1)
 126
 127 enum {
 128     NONE,
 129     ODD_TYPE,
 130     EVEN_TYPE
 131 };
 132
 133 typedef struct TrivialCommandHeader {
 134     Tcl_Interp *interp;         /* The interp that this command lives in. */
 135     Tk_OptionTable optionTable; /* The option table that go with this
 136                                  * command. */
 137     Tk_Window tkwin;            /* For widgets, the window associated with
 138                                  * this widget. */
 139     Tcl_Command widgetCmd;      /* For widgets, the command associated with
 140                                  * this widget. */
 141 } TrivialCommandHeader;
 142
 143 /*
 144  * Forward declarations for functions defined later in this file:
 145  */
 146
 147 static int              ImageObjCmd(ClientData dummy,
 148                             Tcl_Interp *interp, int objc,
 149                             Tcl_Obj * const objv[]);
 150 static int              TestbitmapObjCmd(ClientData dummy,
 151                             Tcl_Interp *interp, int objc,
 152                             Tcl_Obj * const objv[]);
 153 static int              TestborderObjCmd(ClientData dummy,
 154                             Tcl_Interp *interp, int objc,
 155                             Tcl_Obj * const objv[]);
 156 static int              TestcolorObjCmd(ClientData dummy,
 157                             Tcl_Interp *interp, int objc,
 158                             Tcl_Obj * const objv[]);
 159 static int              TestcursorObjCmd(ClientData dummy,
 160                             Tcl_Interp *interp, int objc,
 161                             Tcl_Obj * const objv[]);
 162 static int              TestdeleteappsObjCmd(ClientData dummy,
 163                             Tcl_Interp *interp, int objc,
 164                             Tcl_Obj * const objv[]);
 165 static int              TestfontObjCmd(ClientData dummy,
 166                             Tcl_Interp *interp, int objc,
 167                             Tcl_Obj *const objv[]);
 168 static int              TestmakeexistObjCmd(ClientData dummy,
 169                             Tcl_Interp *interp, int objc,
 170                             Tcl_Obj *const objv[]);
 171 #if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__))
 172 static int              TestmenubarObjCmd(ClientData dummy,
 173                             Tcl_Interp *interp, int objc,
 174                             Tcl_Obj *const objv[]);
 175 #endif
 176 #if defined(_WIN32)
 177 static int              TestmetricsObjCmd(ClientData dummy,
 178                             Tcl_Interp *interp, int objc,
 179                             Tcl_Obj * const objv[]);
 180 #endif
 181 static int              TestobjconfigObjCmd(ClientData dummy,
 182                             Tcl_Interp *interp, int objc,
 183                             Tcl_Obj * const objv[]);
 184 static int              CustomOptionSet(ClientData clientData,
 185                             Tcl_Interp *interp, Tk_Window tkwin,
 186                             Tcl_Obj **value, char *recordPtr,
 187                             int internalOffset, char *saveInternalPtr,
 188                             int flags);
 189 static Tcl_Obj *        CustomOptionGet(ClientData clientData,
 190                             Tk_Window tkwin, char *recordPtr,
 191                             int internalOffset);
 192 static void             CustomOptionRestore(ClientData clientData,
 193                             Tk_Window tkwin, char *internalPtr,
 194                             char *saveInternalPtr);
 195 static void             CustomOptionFree(ClientData clientData,
 196                             Tk_Window tkwin, char *internalPtr);
 197 static int              TestpropObjCmd(ClientData dummy,
 198                             Tcl_Interp *interp, int objc,
 199                             Tcl_Obj * const objv[]);
 200 #if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__))
 201 static int              TestwrapperObjCmd(ClientData dummy,
 202                             Tcl_Interp *interp, int objc,
 203                             Tcl_Obj * const objv[]);
 204 #endif
 205 static void             TrivialCmdDeletedProc(ClientData clientData);
 206 static int              TrivialConfigObjCmd(ClientData dummy,
 207                             Tcl_Interp *interp, int objc,
 208                             Tcl_Obj * const objv[]);
 209 static void             TrivialEventProc(ClientData clientData,
 210                             XEvent *eventPtr);
 211 \f
 212 /*
 213  *----------------------------------------------------------------------
 214  *
 215  * Tktest_Init --
 216  *
 217  *      This function performs initialization for the Tk test suite extensions.
 218  *
 219  * Results:
 220  *      Returns a standard Tcl completion code, and leaves an error message in
 221  *      the interp's result if an error occurs.
 222  *
 223  * Side effects:
 224  *      Creates several test commands.
 225  *
 226  *----------------------------------------------------------------------
 227  */
 228
 229 int
 230 Tktest_Init(
 231     Tcl_Interp *interp)         /* Interpreter for application. */
 232 {
 233     static int initialized = 0;
 234
 235     if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
 236         return TCL_ERROR;
 237     }
 238     if (Tk_InitStubs(interp, TK_VERSION, 0) == NULL) {
 239         return TCL_ERROR;
 240     }
 241
 242     /*
 243      * Create additional commands for testing Tk.
 244      */
 245
 246     if (Tcl_PkgProvideEx(interp, "Tktest", TK_PATCH_LEVEL, NULL) == TCL_ERROR) {
 247         return TCL_ERROR;
 248     }
 249
 250     Tcl_CreateObjCommand(interp, "square", SquareObjCmd, NULL, NULL);
 251     Tcl_CreateObjCommand(interp, "testbitmap", TestbitmapObjCmd,
 252             (ClientData) Tk_MainWindow(interp), NULL);
 253     Tcl_CreateObjCommand(interp, "testborder", TestborderObjCmd,
 254             (ClientData) Tk_MainWindow(interp), NULL);
 255     Tcl_CreateObjCommand(interp, "testcolor", TestcolorObjCmd,
 256             (ClientData) Tk_MainWindow(interp), NULL);
 257     Tcl_CreateObjCommand(interp, "testcursor", TestcursorObjCmd,
 258             (ClientData) Tk_MainWindow(interp), NULL);
 259     Tcl_CreateObjCommand(interp, "testdeleteapps", TestdeleteappsObjCmd,
 260             (ClientData) Tk_MainWindow(interp), NULL);
 261     Tcl_CreateObjCommand(interp, "testembed", TkpTestembedCmd,
 262             (ClientData) Tk_MainWindow(interp), NULL);
 263     Tcl_CreateObjCommand(interp, "testobjconfig", TestobjconfigObjCmd,
 264             (ClientData) Tk_MainWindow(interp), NULL);
 265     Tcl_CreateObjCommand(interp, "testfont", TestfontObjCmd,
 266             (ClientData) Tk_MainWindow(interp), NULL);
 267     Tcl_CreateObjCommand(interp, "testmakeexist", TestmakeexistObjCmd,
 268             (ClientData) Tk_MainWindow(interp), NULL);
 269     Tcl_CreateObjCommand(interp, "testprop", TestpropObjCmd,
 270             (ClientData) Tk_MainWindow(interp), NULL);
 271     Tcl_CreateObjCommand(interp, "testtext", TkpTesttextCmd,
 272             (ClientData) Tk_MainWindow(interp), NULL);
 273
 274 #if defined(_WIN32)
 275     Tcl_CreateObjCommand(interp, "testmetrics", TestmetricsObjCmd,
 276             (ClientData) Tk_MainWindow(interp), NULL);
 277 #elif !defined(__CYGWIN__) && !defined(MAC_OSX_TK)
 278     Tcl_CreateObjCommand(interp, "testmenubar", TestmenubarObjCmd,
 279             (ClientData) Tk_MainWindow(interp), NULL);
 280     Tcl_CreateObjCommand(interp, "testsend", TkpTestsendCmd,
 281             (ClientData) Tk_MainWindow(interp), NULL);
 282     Tcl_CreateObjCommand(interp, "testwrapper", TestwrapperObjCmd,
 283             (ClientData) Tk_MainWindow(interp), NULL);
 284 #endif /* _WIN32 */
 285
 286     /*
 287      * Create test image type.
 288      */
 289
 290     if (!initialized) {
 291         initialized = 1;
 292         Tk_CreateImageType(&imageType);
 293     }
 294
 295     /*
 296      *  Enable testing of legacy interfaces.
 297      */
 298
 299     if (TkOldTestInit(interp) != TCL_OK) {
 300         return TCL_ERROR;
 301     }
 302
 303     /*
 304      * And finally add any platform specific test commands.
 305      */
 306
 307     return TkplatformtestInit(interp);
 308 }
 309 \f
 310 /*
 311  *----------------------------------------------------------------------
 312  *
 313  * TestbitmapObjCmd --
 314  *
 315  *      This function implements the "testbitmap" command, which is used to
 316  *      test color resource handling in tkBitmap tmp.c.
 317  *
 318  * Results:
 319  *      A standard Tcl result.
 320  *
 321  * Side effects:
 322  *      None.
 323  *
 324  *----------------------------------------------------------------------
 325  */
 326
 327 static int
 328 TestbitmapObjCmd(
 329     TCL_UNUSED(void *), /* Main window for application. */
 330     Tcl_Interp *interp,         /* Current interpreter. */
 331     int objc,                   /* Number of arguments. */
 332     Tcl_Obj *const objv[])      /* Argument objects. */
 333 {
 334
 335     if (objc < 2) {
 336         Tcl_WrongNumArgs(interp, 1, objv, "bitmap");
 337         return TCL_ERROR;
 338     }
 339     Tcl_SetObjResult(interp, TkDebugBitmap(Tk_MainWindow(interp),
 340             Tcl_GetString(objv[1])));
 341     return TCL_OK;
 342 }
 343 \f
 344 /*
 345  *----------------------------------------------------------------------
 346  *
 347  * TestborderObjCmd --
 348  *
 349  *      This function implements the "testborder" command, which is used to
 350  *      test color resource handling in tkBorder.c.
 351  *
 352  * Results:
 353  *      A standard Tcl result.
 354  *
 355  * Side effects:
 356  *      None.
 357  *
 358  *----------------------------------------------------------------------
 359  */
 360
 361 static int
 362 TestborderObjCmd(
 363     TCL_UNUSED(ClientData),     /* Main window for application. */
 364     Tcl_Interp *interp,         /* Current interpreter. */
 365     int objc,                   /* Number of arguments. */
 366     Tcl_Obj *const objv[])      /* Argument objects. */
 367 {
 368
 369     if (objc < 2) {
 370         Tcl_WrongNumArgs(interp, 1, objv, "border");
 371         return TCL_ERROR;
 372     }
 373     Tcl_SetObjResult(interp, TkDebugBorder(Tk_MainWindow(interp),
 374             Tcl_GetString(objv[1])));
 375     return TCL_OK;
 376 }
 377 \f
 378 /*
 379  *----------------------------------------------------------------------
 380  *
 381  * TestcolorObjCmd --
 382  *
 383  *      This function implements the "testcolor" command, which is used to
 384  *      test color resource handling in tkColor.c.
 385  *
 386  * Results:
 387  *      A standard Tcl result.
 388  *
 389  * Side effects:
 390  *      None.
 391  *
 392  *----------------------------------------------------------------------
 393  */
 394
 395 static int
 396 TestcolorObjCmd(
 397     TCL_UNUSED(void *), /* Main window for application. */
 398     Tcl_Interp *interp,         /* Current interpreter. */
 399     int objc,                   /* Number of arguments. */
 400     Tcl_Obj *const objv[])      /* Argument objects. */
 401 {
 402     if (objc < 2) {
 403         Tcl_WrongNumArgs(interp, 1, objv, "color");
 404         return TCL_ERROR;
 405     }
 406     Tcl_SetObjResult(interp, TkDebugColor(Tk_MainWindow(interp),
 407             Tcl_GetString(objv[1])));
 408     return TCL_OK;
 409 }
 410 \f
 411 /*
 412  *----------------------------------------------------------------------
 413  *
 414  * TestcursorObjCmd --
 415  *
 416  *      This function implements the "testcursor" command, which is used to
 417  *      test color resource handling in tkCursor.c.
 418  *
 419  * Results:
 420  *      A standard Tcl result.
 421  *
 422  * Side effects:
 423  *      None.
 424  *
 425  *----------------------------------------------------------------------
 426  */
 427
 428 static int
 429 TestcursorObjCmd(
 430     TCL_UNUSED(void *), /* Main window for application. */
 431     Tcl_Interp *interp,         /* Current interpreter. */
 432     int objc,                   /* Number of arguments. */
 433     Tcl_Obj *const objv[])      /* Argument objects. */
 434 {
 435     if (objc < 2) {
 436         Tcl_WrongNumArgs(interp, 1, objv, "cursor");
 437         return TCL_ERROR;
 438     }
 439     Tcl_SetObjResult(interp, TkDebugCursor(Tk_MainWindow(interp),
 440             Tcl_GetString(objv[1])));
 441     return TCL_OK;
 442 }
 443 \f
 444 /*
 445  *----------------------------------------------------------------------
 446  *
 447  * TestdeleteappsObjCmd --
 448  *
 449  *      This function implements the "testdeleteapps" command. It cleans up
 450  *      all the interpreters left behind by the "testnewapp" command.
 451  *
 452  * Results:
 453  *      A standard Tcl result.
 454  *
 455  * Side effects:
 456  *      All the interpreters created by previous calls to "testnewapp" get
 457  *      deleted.
 458  *
 459  *----------------------------------------------------------------------
 460  */
 461
 462 static int
 463 TestdeleteappsObjCmd(
 464     TCL_UNUSED(void *), /* Main window for application. */
 465     TCL_UNUSED(Tcl_Interp *),           /* Current interpreter. */
 466     TCL_UNUSED(int),                    /* Number of arguments. */
 467     TCL_UNUSED(Tcl_Obj *const *))               /* Argument strings. */
 468 {
 469     NewApp *nextPtr;
 470
 471     while (newAppPtr != NULL) {
 472         nextPtr = newAppPtr->nextPtr;
 473         Tcl_DeleteInterp(newAppPtr->interp);
 474         ckfree(newAppPtr);
 475         newAppPtr = nextPtr;
 476     }
 477
 478     return TCL_OK;
 479 }
 480 \f
 481 /*
 482  *----------------------------------------------------------------------
 483  *
 484  * TestobjconfigObjCmd --
 485  *
 486  *      This function implements the "testobjconfig" command, which is used to
 487  *      test the functions in tkConfig.c.
 488  *
 489  * Results:
 490  *      A standard Tcl result.
 491  *
 492  * Side effects:
 493  *      None.
 494  *
 495  *----------------------------------------------------------------------
 496  */
 497
 498 static int
 499 TestobjconfigObjCmd(
 500     ClientData clientData,      /* Main window for application. */
 501     Tcl_Interp *interp,         /* Current interpreter. */
 502     int objc,                   /* Number of arguments. */
 503     Tcl_Obj *const objv[])      /* Argument objects. */
 504 {
 505     static const char *const options[] = {
 506         "alltypes", "chain1", "chain2", "chain3", "configerror", "delete", "info",
 507         "internal", "new", "notenoughparams", "twowindows", NULL
 508     };
 509     enum {
 510         ALL_TYPES, CHAIN1, CHAIN2, CHAIN3, CONFIG_ERROR,
 511         DEL,                    /* Can't use DELETE: VC++ compiler barfs. */
 512         INFO, INTERNAL, NEW, NOT_ENOUGH_PARAMS, TWO_WINDOWS
 513     };
 514     static Tk_OptionTable tables[11];
 515                                 /* Holds pointers to option tables created by
 516                                  * commands below; indexed with same values as
 517                                  * "options" array. */
 518     static const Tk_ObjCustomOption CustomOption = {
 519         "custom option",
 520         CustomOptionSet,
 521         CustomOptionGet,
 522         CustomOptionRestore,
 523         CustomOptionFree,
 524         INT2PTR(1)
 525     };
 526     Tk_Window mainWin = (Tk_Window) clientData;
 527     Tk_Window tkwin;
 528     int index, result = TCL_OK;
 529
 530     /*
 531      * Structures used by the "chain1" subcommand and also shared by the
 532      * "chain2" subcommand:
 533      */
 534
 535     typedef struct ExtensionWidgetRecord {
 536         TrivialCommandHeader header;
 537         Tcl_Obj *base1ObjPtr;
 538         Tcl_Obj *base2ObjPtr;
 539         Tcl_Obj *extension3ObjPtr;
 540         Tcl_Obj *extension4ObjPtr;
 541         Tcl_Obj *extension5ObjPtr;
 542     } ExtensionWidgetRecord;
 543     static const Tk_OptionSpec baseSpecs[] = {
 544         {TK_OPTION_STRING, "-one", "one", "One", "one",
 545                 Tk_Offset(ExtensionWidgetRecord, base1ObjPtr), -1, 0, NULL, 0},
 546         {TK_OPTION_STRING, "-two", "two", "Two", "two",
 547                 Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), -1, 0, NULL, 0},
 548         {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
 549     };
 550
 551     if (objc < 2) {
 552         Tcl_WrongNumArgs(interp, 1, objv, "command");
 553         return TCL_ERROR;
 554     }
 555
 556     if (Tcl_GetIndexFromObjStruct(interp, objv[1], options,
 557             sizeof(char *), "command", 0, &index)!= TCL_OK) {
 558         return TCL_ERROR;
 559     }
 560
 561     switch (index) {
 562     case ALL_TYPES: {
 563         typedef struct TypesRecord {
 564             TrivialCommandHeader header;
 565             Tcl_Obj *booleanPtr;
 566             Tcl_Obj *integerPtr;
 567             Tcl_Obj *doublePtr;
 568             Tcl_Obj *stringPtr;
 569             Tcl_Obj *stringTablePtr;
 570             Tcl_Obj *colorPtr;
 571             Tcl_Obj *fontPtr;
 572             Tcl_Obj *bitmapPtr;
 573             Tcl_Obj *borderPtr;
 574             Tcl_Obj *reliefPtr;
 575             Tcl_Obj *cursorPtr;
 576             Tcl_Obj *activeCursorPtr;
 577             Tcl_Obj *justifyPtr;
 578             Tcl_Obj *anchorPtr;
 579             Tcl_Obj *pixelPtr;
 580             Tcl_Obj *mmPtr;
 581             Tcl_Obj *customPtr;
 582         } TypesRecord;
 583         TypesRecord *recordPtr;
 584         static const char *const stringTable[] = {
 585             "one", "two", "three", "four", NULL
 586         };
 587         static const Tk_OptionSpec typesSpecs[] = {
 588             {TK_OPTION_BOOLEAN, "-boolean", "boolean", "Boolean", "1",
 589                 Tk_Offset(TypesRecord, booleanPtr), -1, 0, 0, 0x1},
 590             {TK_OPTION_INT, "-integer", "integer", "Integer", "7",
 591                 Tk_Offset(TypesRecord, integerPtr), -1, 0, 0, 0x2},
 592             {TK_OPTION_DOUBLE, "-double", "double", "Double", "3.14159",
 593                 Tk_Offset(TypesRecord, doublePtr), -1, 0, 0, 0x4},
 594             {TK_OPTION_STRING, "-string", "string", "String",
 595                 "foo", Tk_Offset(TypesRecord, stringPtr), -1,
 596                 TK_CONFIG_NULL_OK, 0, 0x8},
 597             {TK_OPTION_STRING_TABLE,
 598                 "-stringtable", "StringTable", "stringTable",
 599                 "one", Tk_Offset(TypesRecord, stringTablePtr), -1,
 600                 TK_CONFIG_NULL_OK, stringTable, 0x10},
 601             {TK_OPTION_COLOR, "-color", "color", "Color",
 602                 "red", Tk_Offset(TypesRecord, colorPtr), -1,
 603                 TK_CONFIG_NULL_OK, "black", 0x20},
 604             {TK_OPTION_FONT, "-font", "font", "Font", "Helvetica 12",
 605                 Tk_Offset(TypesRecord, fontPtr), -1,
 606                 TK_CONFIG_NULL_OK, 0, 0x40},
 607             {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", "gray50",
 608                 Tk_Offset(TypesRecord, bitmapPtr), -1,
 609                 TK_CONFIG_NULL_OK, 0, 0x80},
 610             {TK_OPTION_BORDER, "-border", "border", "Border",
 611                 "blue", Tk_Offset(TypesRecord, borderPtr), -1,
 612                 TK_CONFIG_NULL_OK, "white", 0x100},
 613             {TK_OPTION_RELIEF, "-relief", "relief", "Relief", "raised",
 614                 Tk_Offset(TypesRecord, reliefPtr), -1,
 615                 TK_CONFIG_NULL_OK, 0, 0x200},
 616             {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", "xterm",
 617                 Tk_Offset(TypesRecord, cursorPtr), -1,
 618                 TK_CONFIG_NULL_OK, 0, 0x400},
 619             {TK_OPTION_JUSTIFY, "-justify", NULL, NULL, "left",
 620                 Tk_Offset(TypesRecord, justifyPtr), -1,
 621                 TK_CONFIG_NULL_OK, 0, 0x800},
 622             {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", NULL,
 623                 Tk_Offset(TypesRecord, anchorPtr), -1,
 624                 TK_CONFIG_NULL_OK, 0, 0x1000},
 625             {TK_OPTION_PIXELS, "-pixel", "pixel", "Pixel",
 626                 "1", Tk_Offset(TypesRecord, pixelPtr), -1,
 627                 TK_CONFIG_NULL_OK, 0, 0x2000},
 628             {TK_OPTION_CUSTOM, "-custom", NULL, NULL,
 629                 "", Tk_Offset(TypesRecord, customPtr), -1,
 630                 TK_CONFIG_NULL_OK, &CustomOption, 0x4000},
 631             {TK_OPTION_SYNONYM, "-synonym", NULL, NULL,
 632                 NULL, 0, -1, 0, "-color", 0x8000},
 633             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
 634         };
 635         Tk_OptionTable optionTable;
 636
 637         optionTable = Tk_CreateOptionTable(interp, typesSpecs);
 638         tables[index] = optionTable;
 639         tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData,
 640                 Tcl_GetString(objv[2]), NULL);
 641         if (tkwin == NULL) {
 642             return TCL_ERROR;
 643         }
 644         Tk_SetClass(tkwin, "Test");
 645
 646         recordPtr = (TypesRecord *)ckalloc(sizeof(TypesRecord));
 647         recordPtr->header.interp = interp;
 648         recordPtr->header.optionTable = optionTable;
 649         recordPtr->header.tkwin = tkwin;
 650         recordPtr->booleanPtr = NULL;
 651         recordPtr->integerPtr = NULL;
 652         recordPtr->doublePtr = NULL;
 653         recordPtr->stringPtr = NULL;
 654         recordPtr->colorPtr = NULL;
 655         recordPtr->fontPtr = NULL;
 656         recordPtr->bitmapPtr = NULL;
 657         recordPtr->borderPtr = NULL;
 658         recordPtr->reliefPtr = NULL;
 659         recordPtr->cursorPtr = NULL;
 660         recordPtr->justifyPtr = NULL;
 661         recordPtr->anchorPtr = NULL;
 662         recordPtr->pixelPtr = NULL;
 663         recordPtr->mmPtr = NULL;
 664         recordPtr->stringTablePtr = NULL;
 665         recordPtr->customPtr = NULL;
 666         result = Tk_InitOptions(interp, (char *) recordPtr, optionTable,
 667                 tkwin);
 668         if (result == TCL_OK) {
 669             recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
 670                     Tcl_GetString(objv[2]), TrivialConfigObjCmd,
 671                     (ClientData) recordPtr, TrivialCmdDeletedProc);
 672             Tk_CreateEventHandler(tkwin, StructureNotifyMask,
 673                     TrivialEventProc, (ClientData) recordPtr);
 674             result = Tk_SetOptions(interp, (char *) recordPtr, optionTable,
 675                     objc-3, objv+3, tkwin, NULL, NULL);
 676             if (result != TCL_OK) {
 677                 Tk_DestroyWindow(tkwin);
 678             }
 679         } else {
 680             Tk_DestroyWindow(tkwin);
 681             ckfree(recordPtr);
 682         }
 683         if (result == TCL_OK) {
 684             Tcl_SetObjResult(interp, objv[2]);
 685         }
 686         break;
 687     }
 688
 689     case CHAIN1: {
 690         ExtensionWidgetRecord *recordPtr;
 691         Tk_OptionTable optionTable;
 692
 693         tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData,
 694                 Tcl_GetString(objv[2]), NULL);
 695         if (tkwin == NULL) {
 696             return TCL_ERROR;
 697         }
 698         Tk_SetClass(tkwin, "Test");
 699         optionTable = Tk_CreateOptionTable(interp, baseSpecs);
 700         tables[index] = optionTable;
 701
 702         recordPtr = (ExtensionWidgetRecord *)ckalloc(sizeof(ExtensionWidgetRecord));
 703         recordPtr->header.interp = interp;
 704         recordPtr->header.optionTable = optionTable;
 705         recordPtr->header.tkwin = tkwin;
 706         recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL;
 707         recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL;
 708         result = Tk_InitOptions(interp, (char *)recordPtr, optionTable, tkwin);
 709         if (result == TCL_OK) {
 710             result = Tk_SetOptions(interp, (char *) recordPtr, optionTable,
 711                     objc-3, objv+3, tkwin, NULL, NULL);
 712             if (result != TCL_OK) {
 713                 Tk_FreeConfigOptions((char *) recordPtr, optionTable, tkwin);
 714             }
 715         }
 716         if (result == TCL_OK) {
 717             recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
 718                     Tcl_GetString(objv[2]), TrivialConfigObjCmd,
 719                     (ClientData) recordPtr, TrivialCmdDeletedProc);
 720             Tk_CreateEventHandler(tkwin, StructureNotifyMask,
 721                     TrivialEventProc, (ClientData) recordPtr);
 722             Tcl_SetObjResult(interp, objv[2]);
 723         }
 724         break;
 725     }
 726
 727     case CHAIN2:
 728     case CHAIN3: {
 729         ExtensionWidgetRecord *recordPtr;
 730         static const Tk_OptionSpec extensionSpecs[] = {
 731             {TK_OPTION_STRING, "-three", "three", "Three", "three",
 732                 Tk_Offset(ExtensionWidgetRecord, extension3ObjPtr), -1, 0, NULL, 0},
 733             {TK_OPTION_STRING, "-four", "four", "Four", "four",
 734                 Tk_Offset(ExtensionWidgetRecord, extension4ObjPtr), -1, 0, NULL, 0},
 735             {TK_OPTION_STRING, "-two", "two", "Two", "two and a half",
 736                 Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), -1, 0, NULL, 0},
 737             {TK_OPTION_STRING,
 738                 "-oneAgain", "oneAgain", "OneAgain", "one again",
 739                 Tk_Offset(ExtensionWidgetRecord, extension5ObjPtr), -1, 0, NULL, 0},
 740             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, -1, 0,
 741                 (ClientData) baseSpecs, 0}
 742         };
 743         Tk_OptionTable optionTable;
 744
 745         tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData,
 746                 Tcl_GetString(objv[2]), NULL);
 747         if (tkwin == NULL) {
 748             return TCL_ERROR;
 749         }
 750         Tk_SetClass(tkwin, "Test");
 751         optionTable = Tk_CreateOptionTable(interp, extensionSpecs);
 752         tables[index] = optionTable;
 753
 754         recordPtr = (ExtensionWidgetRecord *)ckalloc(sizeof(ExtensionWidgetRecord));
 755         recordPtr->header.interp = interp;
 756         recordPtr->header.optionTable = optionTable;
 757         recordPtr->header.tkwin = tkwin;
 758         recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL;
 759         recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL;
 760         recordPtr->extension5ObjPtr = NULL;
 761         result = Tk_InitOptions(interp, (char *)recordPtr, optionTable, tkwin);
 762         if (result == TCL_OK) {
 763             result = Tk_SetOptions(interp, (char *) recordPtr, optionTable,
 764                     objc-3, objv+3, tkwin, NULL, NULL);
 765             if (result != TCL_OK) {
 766                 Tk_FreeConfigOptions((char *) recordPtr, optionTable, tkwin);
 767             }
 768         }
 769         if (result == TCL_OK) {
 770             recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
 771                     Tcl_GetString(objv[2]), TrivialConfigObjCmd,
 772                     (ClientData) recordPtr, TrivialCmdDeletedProc);
 773             Tk_CreateEventHandler(tkwin, StructureNotifyMask,
 774                     TrivialEventProc, (ClientData) recordPtr);
 775             Tcl_SetObjResult(interp, objv[2]);
 776         }
 777         break;
 778     }
 779
 780     case CONFIG_ERROR: {
 781         typedef struct ErrorWidgetRecord {
 782             Tcl_Obj *intPtr;
 783         } ErrorWidgetRecord;
 784         ErrorWidgetRecord widgetRecord;
 785         static const Tk_OptionSpec errorSpecs[] = {
 786             {TK_OPTION_INT, "-int", "integer", "Integer", "bogus",
 787                 Tk_Offset(ErrorWidgetRecord, intPtr), 0, 0, NULL, 0},
 788             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
 789         };
 790         Tk_OptionTable optionTable;
 791
 792         widgetRecord.intPtr = NULL;
 793         optionTable = Tk_CreateOptionTable(interp, errorSpecs);
 794         tables[index] = optionTable;
 795         return Tk_InitOptions(interp, (char *) &widgetRecord, optionTable,
 796                 (Tk_Window) NULL);
 797     }
 798
 799     case DEL:
 800         if (objc != 3) {
 801             Tcl_WrongNumArgs(interp, 2, objv, "tableName");
 802             return TCL_ERROR;
 803         }
 804         if (Tcl_GetIndexFromObjStruct(interp, objv[2], options,
 805                 sizeof(char *), "table", 0, &index) != TCL_OK) {
 806             return TCL_ERROR;
 807         }
 808         if (tables[index] != NULL) {
 809             Tk_DeleteOptionTable(tables[index]);
 810             /* Make sure that Tk_DeleteOptionTable() is never done
 811              * twice for the same table. */
 812             tables[index] = NULL;
 813         }
 814         break;
 815
 816     case INFO:
 817         if (objc != 3) {
 818             Tcl_WrongNumArgs(interp, 2, objv, "tableName");
 819             return TCL_ERROR;
 820         }
 821         if (Tcl_GetIndexFromObjStruct(interp, objv[2], options,
 822                 sizeof(char *), "table", 0, &index) != TCL_OK) {
 823             return TCL_ERROR;
 824         }
 825         Tcl_SetObjResult(interp, TkDebugConfig(interp, tables[index]));
 826         break;
 827
 828     case INTERNAL: {
 829         /*
 830          * This command is similar to the "alltypes" command except that it
 831          * stores all the configuration options as internal forms instead of
 832          * objects.
 833          */
 834
 835         typedef struct InternalRecord {
 836             TrivialCommandHeader header;
 837             int boolean;
 838             int integer;
 839             double doubleValue;
 840             char *string;
 841             int index;
 842             XColor *colorPtr;
 843             Tk_Font tkfont;
 844             Pixmap bitmap;
 845             Tk_3DBorder border;
 846             int relief;
 847             Tk_Cursor cursor;
 848             Tk_Justify justify;
 849             Tk_Anchor anchor;
 850             int pixels;
 851             double mm;
 852             Tk_Window tkwin;
 853             char *custom;
 854         } InternalRecord;
 855         InternalRecord *recordPtr;
 856         static const char *const internalStringTable[] = {
 857             "one", "two", "three", "four", NULL
 858         };
 859         static const Tk_OptionSpec internalSpecs[] = {
 860             {TK_OPTION_BOOLEAN, "-boolean", "boolean", "Boolean", "1",
 861                 -1, Tk_Offset(InternalRecord, boolean), 0, 0, 0x1},
 862             {TK_OPTION_INT, "-integer", "integer", "Integer", "148962237",
 863                 -1, Tk_Offset(InternalRecord, integer), 0, 0, 0x2},
 864             {TK_OPTION_DOUBLE, "-double", "double", "Double", "3.14159",
 865                 -1, Tk_Offset(InternalRecord, doubleValue), 0, 0, 0x4},
 866             {TK_OPTION_STRING, "-string", "string", "String", "foo",
 867                 -1, Tk_Offset(InternalRecord, string),
 868                 TK_CONFIG_NULL_OK, 0, 0x8},
 869             {TK_OPTION_STRING_TABLE,
 870                 "-stringtable", "StringTable", "stringTable", "one",
 871                 -1, Tk_Offset(InternalRecord, index),
 872                 TK_CONFIG_NULL_OK, internalStringTable, 0x10},
 873             {TK_OPTION_COLOR, "-color", "color", "Color", "red",
 874                 -1, Tk_Offset(InternalRecord, colorPtr),
 875                 TK_CONFIG_NULL_OK, "black", 0x20},
 876             {TK_OPTION_FONT, "-font", "font", "Font", "Helvetica 12",
 877                 -1, Tk_Offset(InternalRecord, tkfont),
 878                 TK_CONFIG_NULL_OK, 0, 0x40},
 879             {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", "gray50",
 880                 -1, Tk_Offset(InternalRecord, bitmap),
 881                 TK_CONFIG_NULL_OK, 0, 0x80},
 882             {TK_OPTION_BORDER, "-border", "border", "Border", "blue",
 883                 -1, Tk_Offset(InternalRecord, border),
 884                 TK_CONFIG_NULL_OK, "white", 0x100},
 885             {TK_OPTION_RELIEF, "-relief", "relief", "Relief", "raised",
 886                 -1, Tk_Offset(InternalRecord, relief),
 887                 TK_CONFIG_NULL_OK, 0, 0x200},
 888             {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", "xterm",
 889                 -1, Tk_Offset(InternalRecord, cursor),
 890                 TK_CONFIG_NULL_OK, 0, 0x400},
 891             {TK_OPTION_JUSTIFY, "-justify", NULL, NULL, "left",
 892                 -1, Tk_Offset(InternalRecord, justify),
 893                 TK_CONFIG_NULL_OK, 0, 0x800},
 894             {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", NULL,
 895                 -1, Tk_Offset(InternalRecord, anchor),
 896                 TK_CONFIG_NULL_OK, 0, 0x1000},
 897             {TK_OPTION_PIXELS, "-pixel", "pixel", "Pixel", "1",
 898                 -1, Tk_Offset(InternalRecord, pixels),
 899                 TK_CONFIG_NULL_OK, 0, 0x2000},
 900             {TK_OPTION_WINDOW, "-window", "window", "Window", NULL,
 901                 -1, Tk_Offset(InternalRecord, tkwin),
 902                 TK_CONFIG_NULL_OK, 0, 0},
 903             {TK_OPTION_CUSTOM, "-custom", NULL, NULL, "",
 904                 -1, Tk_Offset(InternalRecord, custom),
 905                 TK_CONFIG_NULL_OK, &CustomOption, 0x4000},
 906             {TK_OPTION_SYNONYM, "-synonym", NULL, NULL,
 907                 NULL, -1, -1, 0, "-color", 0x8000},
 908             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
 909         };
 910         Tk_OptionTable optionTable;
 911
 912         optionTable = Tk_CreateOptionTable(interp, internalSpecs);
 913         tables[index] = optionTable;
 914         tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData,
 915                 Tcl_GetString(objv[2]), NULL);
 916         if (tkwin == NULL) {
 917             return TCL_ERROR;
 918         }
 919         Tk_SetClass(tkwin, "Test");
 920
 921         recordPtr = ckalloc(sizeof(InternalRecord));
 922         recordPtr->header.interp = interp;
 923         recordPtr->header.optionTable = optionTable;
 924         recordPtr->header.tkwin = tkwin;
 925         recordPtr->boolean = 0;
 926         recordPtr->integer = 0;
 927         recordPtr->doubleValue = 0.0;
 928         recordPtr->string = NULL;
 929         recordPtr->index = 0;
 930         recordPtr->colorPtr = NULL;
 931         recordPtr->tkfont = NULL;
 932         recordPtr->bitmap = None;
 933         recordPtr->border = NULL;
 934         recordPtr->relief = TK_RELIEF_FLAT;
 935         recordPtr->cursor = NULL;
 936         recordPtr->justify = TK_JUSTIFY_LEFT;
 937         recordPtr->anchor = TK_ANCHOR_N;
 938         recordPtr->pixels = 0;
 939         recordPtr->mm = 0.0;
 940         recordPtr->tkwin = NULL;
 941         recordPtr->custom = NULL;
 942         result = Tk_InitOptions(interp, (char *) recordPtr, optionTable,
 943                 tkwin);
 944         if (result == TCL_OK) {
 945             recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
 946                     Tcl_GetString(objv[2]), TrivialConfigObjCmd,
 947                     recordPtr, TrivialCmdDeletedProc);
 948             Tk_CreateEventHandler(tkwin, StructureNotifyMask,
 949                     TrivialEventProc, recordPtr);
 950             result = Tk_SetOptions(interp, (char *) recordPtr, optionTable,
 951                     objc - 3, objv + 3, tkwin, NULL, NULL);
 952             if (result != TCL_OK) {
 953                 Tk_DestroyWindow(tkwin);
 954             }
 955         } else {
 956             Tk_DestroyWindow(tkwin);
 957             ckfree(recordPtr);
 958         }
 959         if (result == TCL_OK) {
 960             Tcl_SetObjResult(interp, objv[2]);
 961         }
 962         break;
 963     }
 964
 965     case NEW: {
 966         typedef struct FiveRecord {
 967             TrivialCommandHeader header;
 968             Tcl_Obj *one;
 969             Tcl_Obj *two;
 970             Tcl_Obj *three;
 971             Tcl_Obj *four;
 972             Tcl_Obj *five;
 973         } FiveRecord;
 974         FiveRecord *recordPtr;
 975         static const Tk_OptionSpec smallSpecs[] = {
 976             {TK_OPTION_INT, "-one", "one", "One", "1",
 977                 Tk_Offset(FiveRecord, one), -1, 0, NULL, 0},
 978             {TK_OPTION_INT, "-two", "two", "Two", "2",
 979                 Tk_Offset(FiveRecord, two), -1, 0, NULL, 0},
 980             {TK_OPTION_INT, "-three", "three", "Three", "3",
 981                 Tk_Offset(FiveRecord, three), -1, 0, NULL, 0},
 982             {TK_OPTION_INT, "-four", "four", "Four", "4",
 983                 Tk_Offset(FiveRecord, four), -1, 0, NULL, 0},
 984             {TK_OPTION_STRING, "-five", NULL, NULL, NULL,
 985                 Tk_Offset(FiveRecord, five), -1, 0, NULL, 0},
 986             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
 987         };
 988
 989         if (objc < 3) {
 990             Tcl_WrongNumArgs(interp, 1, objv, "new name ?-option value ...?");
 991             return TCL_ERROR;
 992         }
 993
 994         recordPtr = ckalloc(sizeof(FiveRecord));
 995         recordPtr->header.interp = interp;
 996         recordPtr->header.optionTable = Tk_CreateOptionTable(interp,
 997                 smallSpecs);
 998         tables[index] = recordPtr->header.optionTable;
 999         recordPtr->header.tkwin = NULL;
1000         recordPtr->one = recordPtr->two = recordPtr->three = NULL;
1001         recordPtr->four = recordPtr->five = NULL;
1002         Tcl_SetObjResult(interp, objv[2]);
1003         result = Tk_InitOptions(interp, (char *) recordPtr,
1004                 recordPtr->header.optionTable, (Tk_Window) NULL);
1005         if (result == TCL_OK) {
1006             result = Tk_SetOptions(interp, (char *) recordPtr,
1007                     recordPtr->header.optionTable, objc - 3, objv + 3,
1008                     (Tk_Window) NULL, NULL, NULL);
1009             if (result == TCL_OK) {
1010                 recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
1011                         Tcl_GetString(objv[2]), TrivialConfigObjCmd,
1012                         (ClientData) recordPtr, TrivialCmdDeletedProc);
1013             } else {
1014                 Tk_FreeConfigOptions((char *) recordPtr,
1015                         recordPtr->header.optionTable, (Tk_Window) NULL);
1016             }
1017         }
1018         if (result != TCL_OK) {
1019             ckfree(recordPtr);
1020         }
1021
1022         break;
1023     }
1024     case NOT_ENOUGH_PARAMS: {
1025         typedef struct NotEnoughRecord {
1026             Tcl_Obj *fooObjPtr;
1027         } NotEnoughRecord;
1028         NotEnoughRecord record;
1029         static const Tk_OptionSpec errorSpecs[] = {
1030             {TK_OPTION_INT, "-foo", "foo", "Foo", "0",
1031                 Tk_Offset(NotEnoughRecord, fooObjPtr), 0, 0, NULL, 0},
1032             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
1033         };
1034         Tcl_Obj *newObjPtr = Tcl_NewStringObj("-foo", -1);
1035         Tk_OptionTable optionTable;
1036
1037         record.fooObjPtr = NULL;
1038
1039         tkwin = Tk_CreateWindowFromPath(interp, mainWin, ".config", NULL);
1040         Tk_SetClass(tkwin, "Config");
1041         optionTable = Tk_CreateOptionTable(interp, errorSpecs);
1042         tables[index] = optionTable;
1043         Tk_InitOptions(interp, (char *) &record, optionTable, tkwin);
1044         if (Tk_SetOptions(interp, (char *) &record, optionTable, 1,
1045                 &newObjPtr, tkwin, NULL, NULL) != TCL_OK) {
1046             result = TCL_ERROR;
1047         }
1048         Tcl_DecrRefCount(newObjPtr);
1049         Tk_FreeConfigOptions( (char *) &record, optionTable, tkwin);
1050         Tk_DestroyWindow(tkwin);
1051         return result;
1052     }
1053
1054     case TWO_WINDOWS: {
1055         typedef struct ContentRecord {
1056             TrivialCommandHeader header;
1057             Tcl_Obj *windowPtr;
1058         } ContentRecord;
1059         ContentRecord *recordPtr;
1060         static const Tk_OptionSpec contentSpecs[] = {
1061             {TK_OPTION_WINDOW, "-window", "window", "Window", ".bar",
1062                 Tk_Offset(ContentRecord, windowPtr), -1, TK_CONFIG_NULL_OK, NULL, 0},
1063             {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
1064         };
1065         tkwin = Tk_CreateWindowFromPath(interp,
1066                 (Tk_Window) clientData, Tcl_GetString(objv[2]), NULL);
1067
1068         if (tkwin == NULL) {
1069             return TCL_ERROR;
1070         }
1071         Tk_SetClass(tkwin, "Test");
1072
1073         recordPtr = (ContentRecord *)ckalloc(sizeof(ContentRecord));
1074         recordPtr->header.interp = interp;
1075         recordPtr->header.optionTable = Tk_CreateOptionTable(interp,
1076                 contentSpecs);
1077         tables[index] = recordPtr->header.optionTable;
1078         recordPtr->header.tkwin = tkwin;
1079         recordPtr->windowPtr = NULL;
1080
1081         result = Tk_InitOptions(interp,  (char *) recordPtr,
1082                 recordPtr->header.optionTable, tkwin);
1083         if (result == TCL_OK) {
1084             result = Tk_SetOptions(interp, (char *) recordPtr,
1085                     recordPtr->header.optionTable, objc - 3, objv + 3,
1086                     tkwin, NULL, NULL);
1087             if (result == TCL_OK) {
1088                 recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp,
1089                         Tcl_GetString(objv[2]), TrivialConfigObjCmd,
1090                         recordPtr, TrivialCmdDeletedProc);
1091                 Tk_CreateEventHandler(tkwin, StructureNotifyMask,
1092                         TrivialEventProc, recordPtr);
1093                 Tcl_SetObjResult(interp, objv[2]);
1094             } else {
1095                 Tk_FreeConfigOptions((char *) recordPtr,
1096                         recordPtr->header.optionTable, tkwin);
1097             }
1098         }
1099         if (result != TCL_OK) {
1100             Tk_DestroyWindow(tkwin);
1101             ckfree(recordPtr);
1102         }
1103     }
1104     }
1105
1106     return result;
1107 }
1108 \f
1109 /*
1110  *----------------------------------------------------------------------
1111  *
1112  * TrivialConfigObjCmd --
1113  *
1114  *      This command is used to test the configuration package. It only
1115  *      handles the "configure" and "cget" subcommands.
1116  *
1117  * Results:
1118  *      A standard Tcl result.
1119  *
1120  * Side effects:
1121  *      None.
1122  *
1123  *----------------------------------------------------------------------
1124  */
1125
1126 static int
1127 TrivialConfigObjCmd(
1128     ClientData clientData,      /* Main window for application. */
1129     Tcl_Interp *interp,         /* Current interpreter. */
1130     int objc,                   /* Number of arguments. */
1131     Tcl_Obj *const objv[])      /* Argument objects. */
1132 {
1133     int result = TCL_OK;
1134     static const char *const options[] = {
1135         "cget", "configure", "csave", NULL
1136     };
1137     enum {
1138         CGET, CONFIGURE, CSAVE
1139     };
1140     Tcl_Obj *resultObjPtr;
1141     int index, mask;
1142     TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData;
1143     Tk_Window tkwin = headerPtr->tkwin;
1144     Tk_SavedOptions saved;
1145
1146     if (objc < 2) {
1147         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg...?");
1148         return TCL_ERROR;
1149     }
1150
1151     if (Tcl_GetIndexFromObjStruct(interp, objv[1], options,
1152             sizeof(char *), "command", 0, &index) != TCL_OK) {
1153         return TCL_ERROR;
1154     }
1155
1156     Tcl_Preserve(clientData);
1157
1158     switch (index) {
1159     case CGET:
1160         if (objc != 3) {
1161             Tcl_WrongNumArgs(interp, 2, objv, "option");
1162             result = TCL_ERROR;
1163             goto done;
1164         }
1165         resultObjPtr = Tk_GetOptionValue(interp, (char *) clientData,
1166                 headerPtr->optionTable, objv[2], tkwin);
1167         if (resultObjPtr != NULL) {
1168             Tcl_SetObjResult(interp, resultObjPtr);
1169             result = TCL_OK;
1170         } else {
1171             result = TCL_ERROR;
1172         }
1173         break;
1174     case CONFIGURE:
1175         if (objc == 2) {
1176             resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData,
1177                     headerPtr->optionTable, NULL, tkwin);
1178             if (resultObjPtr == NULL) {
1179                 result = TCL_ERROR;
1180             } else {
1181                 Tcl_SetObjResult(interp, resultObjPtr);
1182             }
1183         } else if (objc == 3) {
1184             resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData,
1185                     headerPtr->optionTable, objv[2], tkwin);
1186             if (resultObjPtr == NULL) {
1187                 result = TCL_ERROR;
1188             } else {
1189                 Tcl_SetObjResult(interp, resultObjPtr);
1190             }
1191         } else {
1192             result = Tk_SetOptions(interp, (char *) clientData,
1193                     headerPtr->optionTable, objc - 2, objv + 2,
1194                     tkwin, NULL, &mask);
1195             if (result == TCL_OK) {
1196                 Tcl_SetObjResult(interp, Tcl_NewIntObj(mask));
1197             }
1198         }
1199         break;
1200     case CSAVE:
1201         result = Tk_SetOptions(interp, (char *) clientData,
1202                 headerPtr->optionTable, objc - 2, objv + 2,
1203                 tkwin, &saved, &mask);
1204         Tk_FreeSavedOptions(&saved);
1205         if (result == TCL_OK) {
1206             Tcl_SetObjResult(interp, Tcl_NewIntObj(mask));
1207         }
1208         break;
1209     }
1210   done:
1211     Tcl_Release(clientData);
1212     return result;
1213 }
1214 \f
1215 /*
1216  *----------------------------------------------------------------------
1217  *
1218  * TrivialCmdDeletedProc --
1219  *
1220  *      This function is invoked when a widget command is deleted. If the
1221  *      widget isn't already in the process of being destroyed, this command
1222  *      destroys it.
1223  *
1224  * Results:
1225  *      None.
1226  *
1227  * Side effects:
1228  *      The widget is destroyed.
1229  *
1230  *----------------------------------------------------------------------
1231  */
1232
1233 static void
1234 TrivialCmdDeletedProc(
1235     ClientData clientData)      /* Pointer to widget record for widget. */
1236 {
1237     TrivialCommandHeader *headerPtr = (TrivialCommandHeader *)clientData;
1238     Tk_Window tkwin = headerPtr->tkwin;
1239
1240     if (tkwin != NULL) {
1241         Tk_DestroyWindow(tkwin);
1242     } else if (headerPtr->optionTable != NULL) {
1243         /*
1244          * This is a "new" object, which doesn't have a window, so we can't
1245          * depend on cleaning up in the event function. Free its resources
1246          * here.
1247          */
1248
1249         Tk_FreeConfigOptions((char *)clientData,
1250                 headerPtr->optionTable, NULL);
1251         Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
1252     }
1253 }
1254 \f
1255 /*
1256  *--------------------------------------------------------------
1257  *
1258  * TrivialEventProc --
1259  *
1260  *      A dummy event proc.
1261  *
1262  * Results:
1263  *      None.
1264  *
1265  * Side effects:
1266  *      When the window gets deleted, internal structures get cleaned up.
1267  *
1268  *--------------------------------------------------------------
1269  */
1270
1271 static void
1272 TrivialEventProc(
1273     ClientData clientData,      /* Information about window. */
1274     XEvent *eventPtr)           /* Information about event. */
1275 {
1276     TrivialCommandHeader *headerPtr = (TrivialCommandHeader *)clientData;
1277
1278     if (eventPtr->type == DestroyNotify) {
1279         if (headerPtr->tkwin != NULL) {
1280             Tk_FreeConfigOptions((char *)clientData,
1281                     headerPtr->optionTable, headerPtr->tkwin);
1282             headerPtr->optionTable = NULL;
1283             headerPtr->tkwin = NULL;
1284             Tcl_DeleteCommandFromToken(headerPtr->interp,
1285                     headerPtr->widgetCmd);
1286         }
1287         Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
1288     }
1289 }
1290 \f
1291 /*
1292  *----------------------------------------------------------------------
1293  *
1294  * TestfontObjCmd --
1295  *
1296  *      This function implements the "testfont" command, which is used to test
1297  *      TkFont objects.
1298  *
1299  * Results:
1300  *      A standard Tcl result.
1301  *
1302  * Side effects:
1303  *      None.
1304  *
1305  *----------------------------------------------------------------------
1306  */
1307
1308 static int
1309 TestfontObjCmd(
1310     ClientData clientData,      /* Main window for application. */
1311     Tcl_Interp *interp,         /* Current interpreter. */
1312     int objc,                   /* Number of arguments. */
1313     Tcl_Obj *const objv[])      /* Argument objects. */
1314 {
1315     static const char *const options[] = {"counts", "subfonts", NULL};
1316     enum option {COUNTS, SUBFONTS};
1317     int index;
1318     Tk_Window tkwin;
1319     Tk_Font tkfont;
1320
1321     tkwin = (Tk_Window)clientData;
1322
1323     if (objc < 3) {
1324         Tcl_WrongNumArgs(interp, 1, objv, "option fontName");
1325         return TCL_ERROR;
1326     }
1327
1328     if (Tcl_GetIndexFromObjStruct(interp, objv[1], options,
1329             sizeof(char *), "command", 0, &index)!= TCL_OK) {
1330         return TCL_ERROR;
1331     }
1332
1333     switch ((enum option) index) {
1334     case COUNTS:
1335         Tcl_SetObjResult(interp,
1336                 TkDebugFont(Tk_MainWindow(interp), Tcl_GetString(objv[2])));
1337         break;
1338     case SUBFONTS:
1339         tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]);
1340         if (tkfont == NULL) {
1341             return TCL_ERROR;
1342         }
1343         TkpGetSubFonts(interp, tkfont);
1344         Tk_FreeFont(tkfont);
1345         break;
1346     }
1347
1348     return TCL_OK;
1349 }
1350 \f
1351 /*
1352  *----------------------------------------------------------------------
1353  *
1354  * ImageCreate --
1355  *
1356  *      This function is called by the Tk image code to create "test" images.
1357  *
1358  * Results:
1359  *      A standard Tcl result.
1360  *
1361  * Side effects:
1362  *      The data structure for a new image is allocated.
1363  *
1364  *----------------------------------------------------------------------
1365  */
1366
1367 static int
1368 ImageCreate(
1369     Tcl_Interp *interp,         /* Interpreter for application containing
1370                                  * image. */
1371     const char *name,                   /* Name to use for image. */
1372     int objc,                   /* Number of arguments. */
1373     Tcl_Obj *const objv[],      /* Argument strings for options (doesn't
1374                                  * include image name or type). */
1375     TCL_UNUSED(const Tk_ImageType *),   /* Pointer to our type record (not used). */
1376         Tk_ImageModel model,    /* Token for image, to be used by us in later
1377                                  * callbacks. */
1378     ClientData *clientDataPtr)  /* Store manager's token for image here; it
1379                                  * will be returned in later callbacks. */
1380 {
1381     TImageModel *timPtr;
1382     const char *varName;
1383     int i;
1384
1385     varName = "log";
1386     for (i = 0; i < objc; i += 2) {
1387         if (strcmp(Tcl_GetString(objv[i]), "-variable") != 0) {
1388             Tcl_AppendResult(interp, "bad option name \"",
1389                     Tcl_GetString(objv[i]), "\"", NULL);
1390             return TCL_ERROR;
1391         }
1392         if ((i+1) == objc) {
1393             Tcl_AppendResult(interp, "no value given for \"",
1394                     Tcl_GetString(objv[i]), "\" option", NULL);
1395             return TCL_ERROR;
1396         }
1397         varName = Tcl_GetString(objv[i+1]);
1398     }
1399
1400     timPtr = (TImageModel *)ckalloc(sizeof(TImageModel));
1401     timPtr->model = model;
1402     timPtr->interp = interp;
1403     timPtr->width = 30;
1404     timPtr->height = 15;
1405     timPtr->imageName = (char *)ckalloc(strlen(name) + 1);
1406     strcpy(timPtr->imageName, name);
1407     timPtr->varName = (char *)ckalloc(strlen(varName) + 1);
1408     strcpy(timPtr->varName, varName);
1409     Tcl_CreateObjCommand(interp, name, ImageObjCmd, timPtr, NULL);
1410     *clientDataPtr = timPtr;
1411     Tk_ImageChanged(model, 0, 0, 30, 15, 30, 15);
1412     return TCL_OK;
1413 }
1414 \f
1415 /*
1416  *----------------------------------------------------------------------
1417  *
1418  * ImageObjCmd --
1419  *
1420  *      This function implements the commands corresponding to individual
1421  *      images.
1422  *
1423  * Results:
1424  *      A standard Tcl result.
1425  *
1426  * Side effects:
1427  *      Forces windows to be created.
1428  *
1429  *----------------------------------------------------------------------
1430  */
1431
1432 static int
1433 ImageObjCmd(
1434     ClientData clientData,      /* Main window for application. */
1435     Tcl_Interp *interp,         /* Current interpreter. */
1436     int objc,                   /* Number of arguments. */
1437     Tcl_Obj *const objv[])              /* Argument strings. */
1438 {
1439     TImageModel *timPtr = (TImageModel *)clientData;
1440     int x, y, width, height;
1441
1442     if (objc < 2) {
1443         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1444         return TCL_ERROR;
1445     }
1446     if (strcmp(Tcl_GetString(objv[1]), "changed") == 0) {
1447         if (objc != 8) {
1448                 Tcl_WrongNumArgs(interp, 1, objv, "changed x y width height"
1449                         " imageWidth imageHeight");
1450             return TCL_ERROR;
1451         }
1452         if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
1453                 || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)
1454                 || (Tcl_GetIntFromObj(interp, objv[4], &width) != TCL_OK)
1455                 || (Tcl_GetIntFromObj(interp, objv[5], &height) != TCL_OK)
1456                 || (Tcl_GetIntFromObj(interp, objv[6], &timPtr->width) != TCL_OK)
1457                 || (Tcl_GetIntFromObj(interp, objv[7], &timPtr->height) != TCL_OK)) {
1458             return TCL_ERROR;
1459         }
1460         Tk_ImageChanged(timPtr->model, x, y, width, height, timPtr->width,
1461                 timPtr->height);
1462     } else {
1463         Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
1464                 "\": must be changed", NULL);
1465         return TCL_ERROR;
1466     }
1467     return TCL_OK;
1468 }
1469 \f
1470 /*
1471  *----------------------------------------------------------------------
1472  *
1473  * ImageGet --
1474  *
1475  *      This function is called by Tk to set things up for using a test image
1476  *      in a particular widget.
1477  *
1478  * Results:
1479  *      The return value is a token for the image instance, which is used in
1480  *      future callbacks to ImageDisplay and ImageFree.
1481  *
1482  * Side effects:
1483  *      None.
1484  *
1485  *----------------------------------------------------------------------
1486  */
1487
1488 static ClientData
1489 ImageGet(
1490     Tk_Window tkwin,            /* Token for window in which image will be
1491                                  * used. */
1492     ClientData clientData)      /* Pointer to TImageModel for image. */
1493 {
1494     TImageModel *timPtr = (TImageModel *)clientData;
1495     TImageInstance *instPtr;
1496     char buffer[100];
1497     XGCValues gcValues;
1498
1499     sprintf(buffer, "%s get", timPtr->imageName);
1500     Tcl_SetVar2(timPtr->interp, timPtr->varName, NULL, buffer,
1501             TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1502
1503     instPtr = (TImageInstance *)ckalloc(sizeof(TImageInstance));
1504     instPtr->modelPtr = timPtr;
1505     instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
1506     gcValues.foreground = instPtr->fg->pixel;
1507     instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
1508     instPtr->displayFailed = False;
1509     return instPtr;
1510 }
1511 \f
1512 /*
1513  *----------------------------------------------------------------------
1514  *
1515  * ImageDisplay --
1516  *
1517  *      This function is invoked to redisplay part or all of an image in a
1518  *      given drawable.
1519  *
1520  * Results:
1521  *      None.
1522  *
1523  * Side effects:
1524  *      The image gets partially redrawn, as an "X" that shows the exact
1525  *      redraw area.
1526  *
1527  *----------------------------------------------------------------------
1528  */
1529
1530 static void
1531 ImageDisplay(
1532     ClientData clientData,      /* Pointer to TImageInstance for image. */
1533     Display *display,           /* Display to use for drawing. */
1534     Drawable drawable,          /* Where to redraw image. */
1535     int imageX, int imageY,     /* Origin of area to redraw, relative to
1536                                  * origin of image. */
1537     int width, int height,      /* Dimensions of area to redraw. */
1538     int drawableX, int drawableY)
1539                                 /* Coordinates in drawable corresponding to
1540                                  * imageX and imageY. */
1541 {
1542     TImageInstance *instPtr = (TImageInstance *)clientData;
1543
1544     /*
1545      * The purpose of the test image type is to track the calls to an image
1546      * display proc and record the parameters passed in each call.  On macOS a
1547      * display proc must be run inside of the drawRect method of an NSView in
1548      * order for the graphics operations to have any effect.  To deal with
1549      * this, whenever a display proc is called outside of any drawRect method
1550      * it schedules a redraw of the NSView.
1551      *
1552      * In an attempt to work around this, each image instance maintains it own
1553      * copy of the log message which gets written on the first call to the
1554      * display proc.  This usually means that the message created on macOS is
1555      * the same as that created on other platforms.  However it is possible
1556      * for the messages to differ for other reasons, namely differences in
1557      * how damage regions are computed.
1558      */
1559
1560     if (LOG_DISPLAY(drawable)) {
1561         if (instPtr->displayFailed == False) {
1562
1563             /*
1564              * Drawing is possible on the first call to DisplayImage.
1565              * Log the message.
1566              */
1567
1568             sprintf(instPtr->buffer, "%s display %d %d %d %d",
1569             instPtr->modelPtr->imageName, imageX, imageY, width, height);
1570         }
1571         Tcl_SetVar2(instPtr->modelPtr->interp, instPtr->modelPtr->varName,
1572                     NULL, instPtr->buffer,
1573                     TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1574         instPtr->displayFailed = False;
1575     } else {
1576
1577         /*
1578          * Drawing is not possible on the first call to DisplayImage.
1579          * Save the message, but do not log it until the actual display.
1580          */
1581
1582         if (instPtr->displayFailed == False) {
1583             sprintf(instPtr->buffer, "%s display %d %d %d %d",
1584                     instPtr->modelPtr->imageName, imageX, imageY, width, height);
1585         }
1586         instPtr->displayFailed = True;
1587     }
1588     if (width > (instPtr->modelPtr->width - imageX)) {
1589         width = instPtr->modelPtr->width - imageX;
1590     }
1591     if (height > (instPtr->modelPtr->height - imageY)) {
1592         height = instPtr->modelPtr->height - imageY;
1593     }
1594
1595     XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY,
1596             (unsigned) (width-1), (unsigned) (height-1));
1597     XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY,
1598             (int) (drawableX + width - 1), (int) (drawableY + height - 1));
1599     XDrawLine(display, drawable, instPtr->gc, drawableX,
1600             (int) (drawableY + height - 1),
1601             (int) (drawableX + width - 1), drawableY);
1602 }
1603 \f
1604 /*
1605  *----------------------------------------------------------------------
1606  *
1607  * ImageFree --
1608  *
1609  *      This function is called when an instance of an image is no longer
1610  *      used.
1611  *
1612  * Results:
1613  *      None.
1614  *
1615  * Side effects:
1616  *      Information related to the instance is freed.
1617  *
1618  *----------------------------------------------------------------------
1619  */
1620
1621 static void
1622 ImageFree(
1623     ClientData clientData,      /* Pointer to TImageInstance for instance. */
1624     Display *display)           /* Display where image was to be drawn. */
1625 {
1626     TImageInstance *instPtr = (TImageInstance *)clientData;
1627     char buffer[200];
1628
1629     sprintf(buffer, "%s free", instPtr->modelPtr->imageName);
1630     Tcl_SetVar2(instPtr->modelPtr->interp, instPtr->modelPtr->varName, NULL,
1631             buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1632     Tk_FreeColor(instPtr->fg);
1633     Tk_FreeGC(display, instPtr->gc);
1634     ckfree(instPtr);
1635 }
1636 \f
1637 /*
1638  *----------------------------------------------------------------------
1639  *
1640  * ImageDelete --
1641  *
1642  *      This function is called to clean up a test image when an application
1643  *      goes away.
1644  *
1645  * Results:
1646  *      None.
1647  *
1648  * Side effects:
1649  *      Information about the image is deleted.
1650  *
1651  *----------------------------------------------------------------------
1652  */
1653
1654 static void
1655 ImageDelete(
1656     ClientData clientData)      /* Pointer to TImageModel for image. When
1657                                  * this function is called, no more instances
1658                                  * exist. */
1659 {
1660     TImageModel *timPtr = (TImageModel *)clientData;
1661     char buffer[100];
1662
1663     sprintf(buffer, "%s delete", timPtr->imageName);
1664     Tcl_SetVar2(timPtr->interp, timPtr->varName, NULL, buffer,
1665             TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
1666
1667     Tcl_DeleteCommand(timPtr->interp, timPtr->imageName);
1668     ckfree(timPtr->imageName);
1669     ckfree(timPtr->varName);
1670     ckfree(timPtr);
1671 }
1672 \f
1673 /*
1674  *----------------------------------------------------------------------
1675  *
1676  * TestmakeexistObjCmd --
1677  *
1678  *      This function implements the "testmakeexist" command. It calls
1679  *      Tk_MakeWindowExist on each of its arguments to force the windows to be
1680  *      created.
1681  *
1682  * Results:
1683  *      A standard Tcl result.
1684  *
1685  * Side effects:
1686  *      Forces windows to be created.
1687  *
1688  *----------------------------------------------------------------------
1689  */
1690
1691 static int
1692 TestmakeexistObjCmd(
1693     ClientData clientData,      /* Main window for application. */
1694     Tcl_Interp *interp,         /* Current interpreter. */
1695     int objc,                   /* Number of arguments. */
1696     Tcl_Obj *const objv[])              /* Argument strings. */
1697 {
1698     Tk_Window mainWin = (Tk_Window)clientData;
1699     int i;
1700     Tk_Window tkwin;
1701
1702     for (i = 1; i < objc; i++) {
1703         tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[i]), mainWin);
1704         if (tkwin == NULL) {
1705             return TCL_ERROR;
1706         }
1707         Tk_MakeWindowExist(tkwin);
1708     }
1709
1710     return TCL_OK;
1711 }
1712 \f
1713 /*
1714  *----------------------------------------------------------------------
1715  *
1716  * TestmenubarObjCmd --
1717  *
1718  *      This function implements the "testmenubar" command. It is used to test
1719  *      the Unix facilities for creating space above a toplevel window for a
1720  *      menubar.
1721  *
1722  * Results:
1723  *      A standard Tcl result.
1724  *
1725  * Side effects:
1726  *      Changes menubar related stuff.
1727  *
1728  *----------------------------------------------------------------------
1729  */
1730
1731 #if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__))
1732 static int
1733 TestmenubarObjCmd(
1734     ClientData clientData,      /* Main window for application. */
1735     Tcl_Interp *interp,         /* Current interpreter. */
1736     int objc,                   /* Number of arguments. */
1737     Tcl_Obj *const objv[])              /* Argument strings. */
1738 {
1739 #ifdef __UNIX__
1740     Tk_Window mainWin = (Tk_Window)clientData;
1741     Tk_Window tkwin, menubar;
1742
1743     if (objc < 2) {
1744         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1745         return TCL_ERROR;
1746     }
1747
1748     if (strcmp(Tcl_GetString(objv[1]), "window") == 0) {
1749         if (objc != 4) {
1750             Tcl_WrongNumArgs(interp, 1, objv, "windows toplevel menubar");
1751             return TCL_ERROR;
1752         }
1753         tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), mainWin);
1754         if (tkwin == NULL) {
1755             return TCL_ERROR;
1756         }
1757         if (Tcl_GetString(objv[3])[0] == 0) {
1758             TkUnixSetMenubar(tkwin, NULL);
1759         } else {
1760             menubar = Tk_NameToWindow(interp, Tcl_GetString(objv[3]), mainWin);
1761             if (menubar == NULL) {
1762                 return TCL_ERROR;
1763             }
1764             TkUnixSetMenubar(tkwin, menubar);
1765         }
1766     } else {
1767         Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
1768                 "\": must be  window", NULL);
1769         return TCL_ERROR;
1770     }
1771
1772     return TCL_OK;
1773 #else
1774     Tcl_AppendResult(interp, "testmenubar is supported only under Unix", NULL);
1775     return TCL_ERROR;
1776 #endif
1777 }
1778 #endif
1779 \f
1780 /*
1781  *----------------------------------------------------------------------
1782  *
1783  * TestmetricsObjCmd --
1784  *
1785  *      This function implements the testmetrics command. It provides a way to
1786  *      determine the size of various widget components.
1787  *
1788  * Results:
1789  *      A standard Tcl result.
1790  *
1791  * Side effects:
1792  *      None.
1793  *
1794  *----------------------------------------------------------------------
1795  */
1796
1797 #if defined(_WIN32)
1798 static int
1799 TestmetricsObjCmd(
1800     TCL_UNUSED(void *), /* Main window for application. */
1801     Tcl_Interp *interp,         /* Current interpreter. */
1802     int objc,                   /* Number of arguments. */
1803     Tcl_Obj *const objv[])              /* Argument strings. */
1804 {
1805     char buf[TCL_INTEGER_SPACE];
1806     int val;
1807
1808     if (objc < 2) {
1809         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1810         return TCL_ERROR;
1811     }
1812
1813     if (strcmp(Tcl_GetString(objv[1]), "cyvscroll") == 0) {
1814         val = GetSystemMetrics(SM_CYVSCROLL);
1815     } else  if (strcmp(Tcl_GetString(objv[1]), "cxhscroll") == 0) {
1816         val = GetSystemMetrics(SM_CXHSCROLL);
1817     } else {
1818         Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
1819                 "\": must be cxhscroll or cyvscroll", NULL);
1820         return TCL_ERROR;
1821     }
1822     sprintf(buf, "%d", val);
1823     Tcl_AppendResult(interp, buf, NULL);
1824     return TCL_OK;
1825 }
1826 #endif
1827 \f
1828 /*
1829  *----------------------------------------------------------------------
1830  *
1831  * TestpropObjCmd --
1832  *
1833  *      This function implements the "testprop" command. It fetches and prints
1834  *      the value of a property on a window.
1835  *
1836  * Results:
1837  *      A standard Tcl result.
1838  *
1839  * Side effects:
1840  *      None.
1841  *
1842  *----------------------------------------------------------------------
1843  */
1844
1845 static int
1846 TestpropObjCmd(
1847     ClientData clientData,      /* Main window for application. */
1848     Tcl_Interp *interp,         /* Current interpreter. */
1849     int objc,                   /* Number of arguments. */
1850     Tcl_Obj *const objv[])              /* Argument strings. */
1851 {
1852     Tk_Window mainWin = (Tk_Window)clientData;
1853     int result, actualFormat;
1854     unsigned long bytesAfter, length, value;
1855     Atom actualType, propName;
1856     unsigned char *property, *p;
1857     char *end;
1858     Window w;
1859     char buffer[30];
1860
1861     if (objc != 3) {
1862         Tcl_WrongNumArgs(interp, 1, objv, "window property");
1863         return TCL_ERROR;
1864     }
1865
1866     w = strtoul(Tcl_GetString(objv[1]), &end, 0);
1867     propName = Tk_InternAtom(mainWin, Tcl_GetString(objv[2]));
1868     property = NULL;
1869     result = XGetWindowProperty(Tk_Display(mainWin),
1870             w, propName, 0, 100000, False, AnyPropertyType,
1871             &actualType, &actualFormat, &length,
1872             &bytesAfter, &property);
1873     if ((result == Success) && (actualType != None)) {
1874         if ((actualFormat == 8) && (actualType == XA_STRING)) {
1875             for (p = property; ((unsigned long)(p-property)) < length; p++) {
1876                 if (*p == 0) {
1877                     *p = '\n';
1878                 }
1879             }
1880             Tcl_SetObjResult(interp, Tcl_NewStringObj((/*!unsigned*/char*)property, -1));
1881         } else {
1882             for (p = property; length > 0; length--) {
1883                 if (actualFormat == 32) {
1884                     value = *((long *) p);
1885                     p += sizeof(long);
1886                 } else if (actualFormat == 16) {
1887                     value = 0xffff & (*((short *) p));
1888                     p += sizeof(short);
1889                 } else {
1890                     value = 0xff & *p;
1891                     p += 1;
1892                 }
1893                 sprintf(buffer, "0x%lx", value);
1894                 Tcl_AppendElement(interp, buffer);
1895             }
1896         }
1897     }
1898     if (property != NULL) {
1899         XFree(property);
1900     }
1901     return TCL_OK;
1902 }
1903 \f
1904 #if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__))
1905 /*
1906  *----------------------------------------------------------------------
1907  *
1908  * TestwrapperObjCmd --
1909  *
1910  *      This function implements the "testwrapper" command. It provides a way
1911  *      from Tcl to determine the extra window Tk adds in between the toplevel
1912  *      window and the window decorations.
1913  *
1914  * Results:
1915  *      A standard Tcl result.
1916  *
1917  * Side effects:
1918  *      None.
1919  *
1920  *----------------------------------------------------------------------
1921  */
1922
1923 static int
1924 TestwrapperObjCmd(
1925     ClientData clientData,      /* Main window for application. */
1926     Tcl_Interp *interp,         /* Current interpreter. */
1927     int objc,                   /* Number of arguments. */
1928     Tcl_Obj *const objv[])              /* Argument strings. */
1929 {
1930     TkWindow *winPtr, *wrapperPtr;
1931     Tk_Window tkwin;
1932
1933     if (objc != 2) {
1934         Tcl_WrongNumArgs(interp, 1, objv, "window");
1935         return TCL_ERROR;
1936     }
1937
1938     tkwin = (Tk_Window)clientData;
1939     winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[1]), tkwin);
1940     if (winPtr == NULL) {
1941         return TCL_ERROR;
1942     }
1943
1944     wrapperPtr = TkpGetWrapperWindow(winPtr);
1945     if (wrapperPtr != NULL) {
1946         char buf[TCL_INTEGER_SPACE];
1947
1948         TkpPrintWindowId(buf, Tk_WindowId(wrapperPtr));
1949         Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
1950     }
1951     return TCL_OK;
1952 }
1953 #endif
1954 \f
1955 /*
1956  *----------------------------------------------------------------------
1957  *
1958  * CustomOptionSet, CustomOptionGet, CustomOptionRestore, CustomOptionFree --
1959  *
1960  *      Handlers for object-based custom configuration options. See
1961  *      Testobjconfigcommand.
1962  *
1963  * Results:
1964  *      See user documentation for expected results from these functions.
1965  *              CustomOptionSet         Standard Tcl Result.
1966  *              CustomOptionGet         Tcl_Obj * containing value.
1967  *              CustomOptionRestore     None.
1968  *              CustomOptionFree        None.
1969  *
1970  * Side effects:
1971  *      Depends on the function.
1972  *              CustomOptionSet         Sets option value to new setting.
1973  *              CustomOptionGet         Creates a new Tcl_Obj.
1974  *              CustomOptionRestore     Resets option value to original value.
1975  *              CustomOptionFree        Free storage for internal rep of option.
1976  *
1977  *----------------------------------------------------------------------
1978  */
1979
1980 static int
1981 CustomOptionSet(
1982     TCL_UNUSED(void *),
1983     Tcl_Interp *interp,
1984     TCL_UNUSED(Tk_Window),
1985     Tcl_Obj **value,
1986     char *recordPtr,
1987     int internalOffset,
1988     char *saveInternalPtr,
1989     int flags)
1990 {
1991     int objEmpty;
1992     char *newStr, *string, *internalPtr;
1993
1994     objEmpty = 0;
1995
1996     if (internalOffset >= 0) {
1997         internalPtr = recordPtr + internalOffset;
1998     } else {
1999         internalPtr = NULL;
2000     }
2001
2002     /*
2003      * See if the object is empty.
2004      */
2005
2006     if (value == NULL) {
2007         objEmpty = 1;
2008         CLANG_ASSERT(value);
2009     } else if ((*value)->bytes != NULL) {
2010         objEmpty = ((*value)->length == 0);
2011     } else {
2012         (void)Tcl_GetString(*value);
2013         objEmpty = ((*value)->length == 0);
2014     }
2015
2016     if ((flags & TK_OPTION_NULL_OK) && objEmpty) {
2017         *value = NULL;
2018     } else {
2019         string = Tcl_GetString(*value);
2020         Tcl_UtfToUpper(string);
2021         if (strcmp(string, "BAD") == 0) {
2022             Tcl_SetObjResult(interp, Tcl_NewStringObj("expected good value, got \"BAD\"", -1));
2023             return TCL_ERROR;
2024         }
2025     }
2026     if (internalPtr != NULL) {
2027         if (*value != NULL) {
2028             string = Tcl_GetString(*value);
2029             newStr = (char *)ckalloc((*value)->length + 1);
2030             strcpy(newStr, string);
2031         } else {
2032             newStr = NULL;
2033         }
2034         *((char **) saveInternalPtr) = *((char **) internalPtr);
2035         *((char **) internalPtr) = newStr;
2036     }
2037
2038     return TCL_OK;
2039 }
2040
2041 static Tcl_Obj *
2042 CustomOptionGet(
2043     TCL_UNUSED(void *),
2044     TCL_UNUSED(Tk_Window),
2045     char *recordPtr,
2046     int internalOffset)
2047 {
2048     return (Tcl_NewStringObj(*(char **)(recordPtr + internalOffset), -1));
2049 }
2050
2051 static void
2052 CustomOptionRestore(
2053     ClientData clientData,
2054     Tk_Window tkwin,
2055     char *internalPtr,
2056     char *saveInternalPtr)
2057 {
2058     *(char **)internalPtr = *(char **)saveInternalPtr;
2059     return;
2060 }
2061
2062 static void
2063 CustomOptionFree(
2064     ClientData clientData,
2065     Tk_Window tkwin,
2066     char *internalPtr)
2067 {
2068     if (*(char **)internalPtr != NULL) {
2069         ckfree(*(char **)internalPtr);
2070     }
2071 }
2072 \f
2073 /*
2074  * Local Variables:
2075  * mode: c
2076  * c-basic-offset: 4
2077  * fill-column: 78
2078  * End:
2079  */