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