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