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