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