diff options
Diffstat (limited to 'tk8.6/generic/tkTest.c')
| -rw-r--r-- | tk8.6/generic/tkTest.c | 2076 |
1 files changed, 0 insertions, 2076 deletions
diff --git a/tk8.6/generic/tkTest.c b/tk8.6/generic/tkTest.c deleted file mode 100644 index fa9e073..0000000 --- a/tk8.6/generic/tkTest.c +++ /dev/null @@ -1,2076 +0,0 @@ -/* - * tkTest.c -- - * - * This file contains C command functions for a bunch of additional Tcl - * commands that are used for testing out Tcl's C interfaces. These - * commands are not normally included in Tcl applications; they're only - * used for testing. - * - * Copyright (c) 1993-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#undef STATIC_BUILD -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif -#ifndef USE_TK_STUBS -# define USE_TK_STUBS -#endif -#include "tkInt.h" -#include "tkText.h" - -#ifdef _WIN32 -#include "tkWinInt.h" -#endif - -#if defined(MAC_OSX_TK) -#include "tkMacOSXInt.h" -#include "tkScrollbar.h" -#endif - -#ifdef __UNIX__ -#include "tkUnixInt.h" -#endif - -/* - * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the - * Tcltest_Init declaration is in the source file itself, which is only - * accessed when we are building a library. - */ - -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLEXPORT -EXTERN int Tktest_Init(Tcl_Interp *interp); -/* - * The following data structure represents the master for a test image: - */ - -typedef struct TImageMaster { - Tk_ImageMaster master; /* Tk's token for image master. */ - Tcl_Interp *interp; /* Interpreter for application. */ - int width, height; /* Dimensions of image. */ - char *imageName; /* Name of image (malloc-ed). */ - char *varName; /* Name of variable in which to log events for - * image (malloc-ed). */ -} TImageMaster; - -/* - * The following data structure represents a particular use of a particular - * test image. - */ - -typedef struct TImageInstance { - TImageMaster *masterPtr; /* Pointer to master for image. */ - XColor *fg; /* Foreground color for drawing in image. */ - GC gc; /* Graphics context for drawing in image. */ -} TImageInstance; - -/* - * The type record for test images: - */ - -static int ImageCreate(Tcl_Interp *interp, - const char *name, int argc, Tcl_Obj *const objv[], - const Tk_ImageType *typePtr, Tk_ImageMaster master, - ClientData *clientDataPtr); -static ClientData ImageGet(Tk_Window tkwin, ClientData clientData); -static void ImageDisplay(ClientData clientData, - Display *display, Drawable drawable, - int imageX, int imageY, int width, - int height, int drawableX, - int drawableY); -static void ImageFree(ClientData clientData, Display *display); -static void ImageDelete(ClientData clientData); - -static Tk_ImageType imageType = { - "test", /* name */ - ImageCreate, /* createProc */ - ImageGet, /* getProc */ - ImageDisplay, /* displayProc */ - ImageFree, /* freeProc */ - ImageDelete, /* deleteProc */ - NULL, /* postscriptPtr */ - NULL, /* nextPtr */ - NULL -}; - -/* - * One of the following structures describes each of the interpreters created - * by the "testnewapp" command. This information is used by the - * "testdeleteinterps" command to destroy all of those interpreters. - */ - -typedef struct NewApp { - Tcl_Interp *interp; /* Token for interpreter. */ - struct NewApp *nextPtr; /* Next in list of new interpreters. */ -} NewApp; - -static NewApp *newAppPtr = NULL;/* First in list of all new interpreters. */ - -/* - * Header for trivial configuration command items. - */ - -#define ODD TK_CONFIG_USER_BIT -#define EVEN (TK_CONFIG_USER_BIT << 1) - -enum { - NONE, - ODD_TYPE, - EVEN_TYPE -}; - -typedef struct TrivialCommandHeader { - Tcl_Interp *interp; /* The interp that this command lives in. */ - Tk_OptionTable optionTable; /* The option table that go with this - * command. */ - Tk_Window tkwin; /* For widgets, the window associated with - * this widget. */ - Tcl_Command widgetCmd; /* For widgets, the command associated with - * this widget. */ -} TrivialCommandHeader; - -/* - * Forward declarations for functions defined later in this file: - */ - -static int ImageObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestbitmapObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestborderObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestcolorObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestcursorObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestdeleteappsObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int TestfontObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestmakeexistObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__)) -static int TestmenubarObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -#endif -#if defined(_WIN32) || defined(MAC_OSX_TK) -static int TestmetricsObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -#endif -static int TestobjconfigObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static int CustomOptionSet(ClientData clientData, - Tcl_Interp *interp, Tk_Window tkwin, - Tcl_Obj **value, char *recordPtr, - int internalOffset, char *saveInternalPtr, - int flags); -static Tcl_Obj * CustomOptionGet(ClientData clientData, - Tk_Window tkwin, char *recordPtr, - int internalOffset); -static void CustomOptionRestore(ClientData clientData, - Tk_Window tkwin, char *internalPtr, - char *saveInternalPtr); -static void CustomOptionFree(ClientData clientData, - Tk_Window tkwin, char *internalPtr); -static int TestpropObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -#if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__)) -static int TestwrapperObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -#endif -static void TrivialCmdDeletedProc(ClientData clientData); -static int TrivialConfigObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj * const objv[]); -static void TrivialEventProc(ClientData clientData, - XEvent *eventPtr); - -/* - *---------------------------------------------------------------------- - * - * Tktest_Init -- - * - * This function performs intialization for the Tk test suite exensions. - * - * Results: - * Returns a standard Tcl completion code, and leaves an error message in - * the interp's result if an error occurs. - * - * Side effects: - * Creates several test commands. - * - *---------------------------------------------------------------------- - */ - -int -Tktest_Init( - Tcl_Interp *interp) /* Interpreter for application. */ -{ - static int initialized = 0; - - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { - return TCL_ERROR; - } - if (Tk_InitStubs(interp, TK_VERSION, 0) == NULL) { - return TCL_ERROR; - } - - /* - * Create additional commands for testing Tk. - */ - - if (Tcl_PkgProvideEx(interp, "Tktest", TK_PATCH_LEVEL, NULL) == TCL_ERROR) { - return TCL_ERROR; - } - - Tcl_CreateObjCommand(interp, "square", SquareObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testbitmap", TestbitmapObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testborder", TestborderObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testcolor", TestcolorObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testcursor", TestcursorObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testdeleteapps", TestdeleteappsObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testembed", TkpTestembedCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testobjconfig", TestobjconfigObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testfont", TestfontObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testmakeexist", TestmakeexistObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testprop", TestpropObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testtext", TkpTesttextCmd, - (ClientData) Tk_MainWindow(interp), NULL); - -#if defined(_WIN32) || defined(MAC_OSX_TK) - Tcl_CreateObjCommand(interp, "testmetrics", TestmetricsObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); -#elif !defined(__CYGWIN__) - Tcl_CreateObjCommand(interp, "testmenubar", TestmenubarObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testsend", TkpTestsendCmd, - (ClientData) Tk_MainWindow(interp), NULL); - Tcl_CreateObjCommand(interp, "testwrapper", TestwrapperObjCmd, - (ClientData) Tk_MainWindow(interp), NULL); -#endif /* _WIN32 || MAC_OSX_TK */ - - /* - * Create test image type. - */ - - if (!initialized) { - initialized = 1; - Tk_CreateImageType(&imageType); - } - - /* - * Enable testing of legacy interfaces. - */ - - if (TkOldTestInit(interp) != TCL_OK) { - return TCL_ERROR; - } - - /* - * And finally add any platform specific test commands. - */ - - return TkplatformtestInit(interp); -} - -/* - *---------------------------------------------------------------------- - * - * TestbitmapObjCmd -- - * - * This function implements the "testbitmap" command, which is used to - * test color resource handling in tkBitmap tmp.c. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestbitmapObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "bitmap"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TkDebugBitmap(Tk_MainWindow(interp), - Tcl_GetString(objv[1]))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestborderObjCmd -- - * - * This function implements the "testborder" command, which is used to - * test color resource handling in tkBorder.c. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestborderObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "border"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TkDebugBorder(Tk_MainWindow(interp), - Tcl_GetString(objv[1]))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestcolorObjCmd -- - * - * This function implements the "testcolor" command, which is used to - * test color resource handling in tkColor.c. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestcolorObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "color"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TkDebugColor(Tk_MainWindow(interp), - Tcl_GetString(objv[1]))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestcursorObjCmd -- - * - * This function implements the "testcursor" command, which is used to - * test color resource handling in tkCursor.c. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestcursorObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cursor"); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TkDebugCursor(Tk_MainWindow(interp), - Tcl_GetString(objv[1]))); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestdeleteappsObjCmd -- - * - * This function implements the "testdeleteapps" command. It cleans up - * all the interpreters left behind by the "testnewapp" command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * All the intepreters created by previous calls to "testnewapp" get - * deleted. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestdeleteappsObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - NewApp *nextPtr; - - while (newAppPtr != NULL) { - nextPtr = newAppPtr->nextPtr; - Tcl_DeleteInterp(newAppPtr->interp); - ckfree(newAppPtr); - newAppPtr = nextPtr; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestobjconfigObjCmd -- - * - * This function implements the "testobjconfig" command, which is used to - * test the functions in tkConfig.c. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestobjconfigObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const options[] = { - "alltypes", "chain1", "chain2", "chain3", "configerror", "delete", "info", - "internal", "new", "notenoughparams", "twowindows", NULL - }; - enum { - ALL_TYPES, CHAIN1, CHAIN2, CHAIN3, CONFIG_ERROR, - DEL, /* Can't use DELETE: VC++ compiler barfs. */ - INFO, INTERNAL, NEW, NOT_ENOUGH_PARAMS, TWO_WINDOWS - }; - static Tk_OptionTable tables[11]; - /* Holds pointers to option tables created by - * commands below; indexed with same values as - * "options" array. */ - static const Tk_ObjCustomOption CustomOption = { - "custom option", - CustomOptionSet, - CustomOptionGet, - CustomOptionRestore, - CustomOptionFree, - INT2PTR(1) - }; - Tk_Window mainWin = (Tk_Window) clientData; - Tk_Window tkwin; - int index, result = TCL_OK; - - /* - * Structures used by the "chain1" subcommand and also shared by the - * "chain2" subcommand: - */ - - typedef struct ExtensionWidgetRecord { - TrivialCommandHeader header; - Tcl_Obj *base1ObjPtr; - Tcl_Obj *base2ObjPtr; - Tcl_Obj *extension3ObjPtr; - Tcl_Obj *extension4ObjPtr; - Tcl_Obj *extension5ObjPtr; - } ExtensionWidgetRecord; - static const Tk_OptionSpec baseSpecs[] = { - {TK_OPTION_STRING, "-one", "one", "One", "one", - Tk_Offset(ExtensionWidgetRecord, base1ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-two", "two", "Two", "two", - Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "command"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, - sizeof(char *), "command", 0, &index)!= TCL_OK) { - return TCL_ERROR; - } - - switch (index) { - case ALL_TYPES: { - typedef struct TypesRecord { - TrivialCommandHeader header; - Tcl_Obj *booleanPtr; - Tcl_Obj *integerPtr; - Tcl_Obj *doublePtr; - Tcl_Obj *stringPtr; - Tcl_Obj *stringTablePtr; - Tcl_Obj *colorPtr; - Tcl_Obj *fontPtr; - Tcl_Obj *bitmapPtr; - Tcl_Obj *borderPtr; - Tcl_Obj *reliefPtr; - Tcl_Obj *cursorPtr; - Tcl_Obj *activeCursorPtr; - Tcl_Obj *justifyPtr; - Tcl_Obj *anchorPtr; - Tcl_Obj *pixelPtr; - Tcl_Obj *mmPtr; - Tcl_Obj *customPtr; - } TypesRecord; - TypesRecord *recordPtr; - static const char *const stringTable[] = { - "one", "two", "three", "four", NULL - }; - static const Tk_OptionSpec typesSpecs[] = { - {TK_OPTION_BOOLEAN, "-boolean", "boolean", "Boolean", "1", - Tk_Offset(TypesRecord, booleanPtr), -1, 0, 0, 0x1}, - {TK_OPTION_INT, "-integer", "integer", "Integer", "7", - Tk_Offset(TypesRecord, integerPtr), -1, 0, 0, 0x2}, - {TK_OPTION_DOUBLE, "-double", "double", "Double", "3.14159", - Tk_Offset(TypesRecord, doublePtr), -1, 0, 0, 0x4}, - {TK_OPTION_STRING, "-string", "string", "String", - "foo", Tk_Offset(TypesRecord, stringPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x8}, - {TK_OPTION_STRING_TABLE, - "-stringtable", "StringTable", "stringTable", - "one", Tk_Offset(TypesRecord, stringTablePtr), -1, - TK_CONFIG_NULL_OK, stringTable, 0x10}, - {TK_OPTION_COLOR, "-color", "color", "Color", - "red", Tk_Offset(TypesRecord, colorPtr), -1, - TK_CONFIG_NULL_OK, "black", 0x20}, - {TK_OPTION_FONT, "-font", "font", "Font", "Helvetica 12", - Tk_Offset(TypesRecord, fontPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x40}, - {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", "gray50", - Tk_Offset(TypesRecord, bitmapPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x80}, - {TK_OPTION_BORDER, "-border", "border", "Border", - "blue", Tk_Offset(TypesRecord, borderPtr), -1, - TK_CONFIG_NULL_OK, "white", 0x100}, - {TK_OPTION_RELIEF, "-relief", "relief", "Relief", "raised", - Tk_Offset(TypesRecord, reliefPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x200}, - {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", "xterm", - Tk_Offset(TypesRecord, cursorPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x400}, - {TK_OPTION_JUSTIFY, "-justify", NULL, NULL, "left", - Tk_Offset(TypesRecord, justifyPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x800}, - {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", NULL, - Tk_Offset(TypesRecord, anchorPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x1000}, - {TK_OPTION_PIXELS, "-pixel", "pixel", "Pixel", - "1", Tk_Offset(TypesRecord, pixelPtr), -1, - TK_CONFIG_NULL_OK, 0, 0x2000}, - {TK_OPTION_CUSTOM, "-custom", NULL, NULL, - "", Tk_Offset(TypesRecord, customPtr), -1, - TK_CONFIG_NULL_OK, &CustomOption, 0x4000}, - {TK_OPTION_SYNONYM, "-synonym", NULL, NULL, - NULL, 0, -1, 0, "-color", 0x8000}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - Tk_OptionTable optionTable; - Tk_Window tkwin; - - optionTable = Tk_CreateOptionTable(interp, typesSpecs); - tables[index] = optionTable; - tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, - Tcl_GetString(objv[2]), NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_SetClass(tkwin, "Test"); - - recordPtr = ckalloc(sizeof(TypesRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = optionTable; - recordPtr->header.tkwin = tkwin; - recordPtr->booleanPtr = NULL; - recordPtr->integerPtr = NULL; - recordPtr->doublePtr = NULL; - recordPtr->stringPtr = NULL; - recordPtr->colorPtr = NULL; - recordPtr->fontPtr = NULL; - recordPtr->bitmapPtr = NULL; - recordPtr->borderPtr = NULL; - recordPtr->reliefPtr = NULL; - recordPtr->cursorPtr = NULL; - recordPtr->justifyPtr = NULL; - recordPtr->anchorPtr = NULL; - recordPtr->pixelPtr = NULL; - recordPtr->mmPtr = NULL; - recordPtr->stringTablePtr = NULL; - recordPtr->customPtr = NULL; - result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, - tkwin); - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - (ClientData) recordPtr, TrivialCmdDeletedProc); - Tk_CreateEventHandler(tkwin, StructureNotifyMask, - TrivialEventProc, (ClientData) recordPtr); - result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, - objc-3, objv+3, tkwin, NULL, NULL); - if (result != TCL_OK) { - Tk_DestroyWindow(tkwin); - } - } else { - Tk_DestroyWindow(tkwin); - ckfree(recordPtr); - } - if (result == TCL_OK) { - Tcl_SetObjResult(interp, objv[2]); - } - break; - } - - case CHAIN1: { - ExtensionWidgetRecord *recordPtr; - Tk_Window tkwin; - Tk_OptionTable optionTable; - - tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, - Tcl_GetString(objv[2]), NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_SetClass(tkwin, "Test"); - optionTable = Tk_CreateOptionTable(interp, baseSpecs); - tables[index] = optionTable; - - recordPtr = ckalloc(sizeof(ExtensionWidgetRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = optionTable; - recordPtr->header.tkwin = tkwin; - recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL; - recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL; - result = Tk_InitOptions(interp, (char *)recordPtr, optionTable, tkwin); - if (result == TCL_OK) { - result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, - objc-3, objv+3, tkwin, NULL, NULL); - if (result != TCL_OK) { - Tk_FreeConfigOptions((char *) recordPtr, optionTable, tkwin); - } - } - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - (ClientData) recordPtr, TrivialCmdDeletedProc); - Tk_CreateEventHandler(tkwin, StructureNotifyMask, - TrivialEventProc, (ClientData) recordPtr); - Tcl_SetObjResult(interp, objv[2]); - } - break; - } - - case CHAIN2: - case CHAIN3: { - ExtensionWidgetRecord *recordPtr; - static const Tk_OptionSpec extensionSpecs[] = { - {TK_OPTION_STRING, "-three", "three", "Three", "three", - Tk_Offset(ExtensionWidgetRecord, extension3ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-four", "four", "Four", "four", - Tk_Offset(ExtensionWidgetRecord, extension4ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-two", "two", "Two", "two and a half", - Tk_Offset(ExtensionWidgetRecord, base2ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_STRING, - "-oneAgain", "oneAgain", "OneAgain", "one again", - Tk_Offset(ExtensionWidgetRecord, extension5ObjPtr), -1, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, -1, 0, - (ClientData) baseSpecs, 0} - }; - Tk_Window tkwin; - Tk_OptionTable optionTable; - - tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, - Tcl_GetString(objv[2]), NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_SetClass(tkwin, "Test"); - optionTable = Tk_CreateOptionTable(interp, extensionSpecs); - tables[index] = optionTable; - - recordPtr = ckalloc(sizeof(ExtensionWidgetRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = optionTable; - recordPtr->header.tkwin = tkwin; - recordPtr->base1ObjPtr = recordPtr->base2ObjPtr = NULL; - recordPtr->extension3ObjPtr = recordPtr->extension4ObjPtr = NULL; - recordPtr->extension5ObjPtr = NULL; - result = Tk_InitOptions(interp, (char *)recordPtr, optionTable, tkwin); - if (result == TCL_OK) { - result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, - objc-3, objv+3, tkwin, NULL, NULL); - if (result != TCL_OK) { - Tk_FreeConfigOptions((char *) recordPtr, optionTable, tkwin); - } - } - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - (ClientData) recordPtr, TrivialCmdDeletedProc); - Tk_CreateEventHandler(tkwin, StructureNotifyMask, - TrivialEventProc, (ClientData) recordPtr); - Tcl_SetObjResult(interp, objv[2]); - } - break; - } - - case CONFIG_ERROR: { - typedef struct ErrorWidgetRecord { - Tcl_Obj *intPtr; - } ErrorWidgetRecord; - ErrorWidgetRecord widgetRecord; - static const Tk_OptionSpec errorSpecs[] = { - {TK_OPTION_INT, "-int", "integer", "Integer", "bogus", - Tk_Offset(ErrorWidgetRecord, intPtr), 0, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - Tk_OptionTable optionTable; - - widgetRecord.intPtr = NULL; - optionTable = Tk_CreateOptionTable(interp, errorSpecs); - tables[index] = optionTable; - return Tk_InitOptions(interp, (char *) &widgetRecord, optionTable, - (Tk_Window) NULL); - } - - case DEL: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "tableName"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObjStruct(interp, objv[2], options, - sizeof(char *), "table", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (tables[index] != NULL) { - Tk_DeleteOptionTable(tables[index]); - /* Make sure that Tk_DeleteOptionTable() is never done - * twice for the same table. */ - tables[index] = NULL; - } - break; - - case INFO: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "tableName"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObjStruct(interp, objv[2], options, - sizeof(char *), "table", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, TkDebugConfig(interp, tables[index])); - break; - - case INTERNAL: { - /* - * This command is similar to the "alltypes" command except that it - * stores all the configuration options as internal forms instead of - * objects. - */ - - typedef struct InternalRecord { - TrivialCommandHeader header; - int boolean; - int integer; - double doubleValue; - char *string; - int index; - XColor *colorPtr; - Tk_Font tkfont; - Pixmap bitmap; - Tk_3DBorder border; - int relief; - Tk_Cursor cursor; - Tk_Justify justify; - Tk_Anchor anchor; - int pixels; - double mm; - Tk_Window tkwin; - char *custom; - } InternalRecord; - InternalRecord *recordPtr; - static const char *const internalStringTable[] = { - "one", "two", "three", "four", NULL - }; - static const Tk_OptionSpec internalSpecs[] = { - {TK_OPTION_BOOLEAN, "-boolean", "boolean", "Boolean", "1", - -1, Tk_Offset(InternalRecord, boolean), 0, 0, 0x1}, - {TK_OPTION_INT, "-integer", "integer", "Integer", "148962237", - -1, Tk_Offset(InternalRecord, integer), 0, 0, 0x2}, - {TK_OPTION_DOUBLE, "-double", "double", "Double", "3.14159", - -1, Tk_Offset(InternalRecord, doubleValue), 0, 0, 0x4}, - {TK_OPTION_STRING, "-string", "string", "String", "foo", - -1, Tk_Offset(InternalRecord, string), - TK_CONFIG_NULL_OK, 0, 0x8}, - {TK_OPTION_STRING_TABLE, - "-stringtable", "StringTable", "stringTable", "one", - -1, Tk_Offset(InternalRecord, index), - TK_CONFIG_NULL_OK, internalStringTable, 0x10}, - {TK_OPTION_COLOR, "-color", "color", "Color", "red", - -1, Tk_Offset(InternalRecord, colorPtr), - TK_CONFIG_NULL_OK, "black", 0x20}, - {TK_OPTION_FONT, "-font", "font", "Font", "Helvetica 12", - -1, Tk_Offset(InternalRecord, tkfont), - TK_CONFIG_NULL_OK, 0, 0x40}, - {TK_OPTION_BITMAP, "-bitmap", "bitmap", "Bitmap", "gray50", - -1, Tk_Offset(InternalRecord, bitmap), - TK_CONFIG_NULL_OK, 0, 0x80}, - {TK_OPTION_BORDER, "-border", "border", "Border", "blue", - -1, Tk_Offset(InternalRecord, border), - TK_CONFIG_NULL_OK, "white", 0x100}, - {TK_OPTION_RELIEF, "-relief", "relief", "Relief", "raised", - -1, Tk_Offset(InternalRecord, relief), - TK_CONFIG_NULL_OK, 0, 0x200}, - {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", "xterm", - -1, Tk_Offset(InternalRecord, cursor), - TK_CONFIG_NULL_OK, 0, 0x400}, - {TK_OPTION_JUSTIFY, "-justify", NULL, NULL, "left", - -1, Tk_Offset(InternalRecord, justify), - TK_CONFIG_NULL_OK, 0, 0x800}, - {TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", NULL, - -1, Tk_Offset(InternalRecord, anchor), - TK_CONFIG_NULL_OK, 0, 0x1000}, - {TK_OPTION_PIXELS, "-pixel", "pixel", "Pixel", "1", - -1, Tk_Offset(InternalRecord, pixels), - TK_CONFIG_NULL_OK, 0, 0x2000}, - {TK_OPTION_WINDOW, "-window", "window", "Window", NULL, - -1, Tk_Offset(InternalRecord, tkwin), - TK_CONFIG_NULL_OK, 0, 0}, - {TK_OPTION_CUSTOM, "-custom", NULL, NULL, "", - -1, Tk_Offset(InternalRecord, custom), - TK_CONFIG_NULL_OK, &CustomOption, 0x4000}, - {TK_OPTION_SYNONYM, "-synonym", NULL, NULL, - NULL, -1, -1, 0, "-color", 0x8000}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - Tk_OptionTable optionTable; - Tk_Window tkwin; - - optionTable = Tk_CreateOptionTable(interp, internalSpecs); - tables[index] = optionTable; - tkwin = Tk_CreateWindowFromPath(interp, (Tk_Window) clientData, - Tcl_GetString(objv[2]), NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_SetClass(tkwin, "Test"); - - recordPtr = ckalloc(sizeof(InternalRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = optionTable; - recordPtr->header.tkwin = tkwin; - recordPtr->boolean = 0; - recordPtr->integer = 0; - recordPtr->doubleValue = 0.0; - recordPtr->string = NULL; - recordPtr->index = 0; - recordPtr->colorPtr = NULL; - recordPtr->tkfont = NULL; - recordPtr->bitmap = None; - recordPtr->border = NULL; - recordPtr->relief = TK_RELIEF_FLAT; - recordPtr->cursor = NULL; - recordPtr->justify = TK_JUSTIFY_LEFT; - recordPtr->anchor = TK_ANCHOR_N; - recordPtr->pixels = 0; - recordPtr->mm = 0.0; - recordPtr->tkwin = NULL; - recordPtr->custom = NULL; - result = Tk_InitOptions(interp, (char *) recordPtr, optionTable, - tkwin); - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - recordPtr, TrivialCmdDeletedProc); - Tk_CreateEventHandler(tkwin, StructureNotifyMask, - TrivialEventProc, recordPtr); - result = Tk_SetOptions(interp, (char *) recordPtr, optionTable, - objc - 3, objv + 3, tkwin, NULL, NULL); - if (result != TCL_OK) { - Tk_DestroyWindow(tkwin); - } - } else { - Tk_DestroyWindow(tkwin); - ckfree(recordPtr); - } - if (result == TCL_OK) { - Tcl_SetObjResult(interp, objv[2]); - } - break; - } - - case NEW: { - typedef struct FiveRecord { - TrivialCommandHeader header; - Tcl_Obj *one; - Tcl_Obj *two; - Tcl_Obj *three; - Tcl_Obj *four; - Tcl_Obj *five; - } FiveRecord; - FiveRecord *recordPtr; - static const Tk_OptionSpec smallSpecs[] = { - {TK_OPTION_INT, "-one", "one", "One", "1", - Tk_Offset(FiveRecord, one), -1, 0, NULL, 0}, - {TK_OPTION_INT, "-two", "two", "Two", "2", - Tk_Offset(FiveRecord, two), -1, 0, NULL, 0}, - {TK_OPTION_INT, "-three", "three", "Three", "3", - Tk_Offset(FiveRecord, three), -1, 0, NULL, 0}, - {TK_OPTION_INT, "-four", "four", "Four", "4", - Tk_Offset(FiveRecord, four), -1, 0, NULL, 0}, - {TK_OPTION_STRING, "-five", NULL, NULL, NULL, - Tk_Offset(FiveRecord, five), -1, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "new name ?-option value ...?"); - return TCL_ERROR; - } - - recordPtr = ckalloc(sizeof(FiveRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = Tk_CreateOptionTable(interp, - smallSpecs); - tables[index] = recordPtr->header.optionTable; - recordPtr->header.tkwin = NULL; - recordPtr->one = recordPtr->two = recordPtr->three = NULL; - recordPtr->four = recordPtr->five = NULL; - Tcl_SetObjResult(interp, objv[2]); - result = Tk_InitOptions(interp, (char *) recordPtr, - recordPtr->header.optionTable, (Tk_Window) NULL); - if (result == TCL_OK) { - result = Tk_SetOptions(interp, (char *) recordPtr, - recordPtr->header.optionTable, objc - 3, objv + 3, - (Tk_Window) NULL, NULL, NULL); - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - (ClientData) recordPtr, TrivialCmdDeletedProc); - } else { - Tk_FreeConfigOptions((char *) recordPtr, - recordPtr->header.optionTable, (Tk_Window) NULL); - } - } - if (result != TCL_OK) { - ckfree(recordPtr); - } - - break; - } - case NOT_ENOUGH_PARAMS: { - typedef struct NotEnoughRecord { - Tcl_Obj *fooObjPtr; - } NotEnoughRecord; - NotEnoughRecord record; - static const Tk_OptionSpec errorSpecs[] = { - {TK_OPTION_INT, "-foo", "foo", "Foo", "0", - Tk_Offset(NotEnoughRecord, fooObjPtr), 0, 0, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - Tcl_Obj *newObjPtr = Tcl_NewStringObj("-foo", -1); - Tk_OptionTable optionTable; - - record.fooObjPtr = NULL; - - tkwin = Tk_CreateWindowFromPath(interp, mainWin, ".config", NULL); - Tk_SetClass(tkwin, "Config"); - optionTable = Tk_CreateOptionTable(interp, errorSpecs); - tables[index] = optionTable; - Tk_InitOptions(interp, (char *) &record, optionTable, tkwin); - if (Tk_SetOptions(interp, (char *) &record, optionTable, 1, - &newObjPtr, tkwin, NULL, NULL) != TCL_OK) { - result = TCL_ERROR; - } - Tcl_DecrRefCount(newObjPtr); - Tk_FreeConfigOptions( (char *) &record, optionTable, tkwin); - Tk_DestroyWindow(tkwin); - return result; - } - - case TWO_WINDOWS: { - typedef struct SlaveRecord { - TrivialCommandHeader header; - Tcl_Obj *windowPtr; - } SlaveRecord; - SlaveRecord *recordPtr; - static const Tk_OptionSpec slaveSpecs[] = { - {TK_OPTION_WINDOW, "-window", "window", "Window", ".bar", - Tk_Offset(SlaveRecord, windowPtr), -1, TK_CONFIG_NULL_OK, NULL, 0}, - {TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0} - }; - Tk_Window tkwin = Tk_CreateWindowFromPath(interp, - (Tk_Window) clientData, Tcl_GetString(objv[2]), NULL); - - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_SetClass(tkwin, "Test"); - - recordPtr = ckalloc(sizeof(SlaveRecord)); - recordPtr->header.interp = interp; - recordPtr->header.optionTable = Tk_CreateOptionTable(interp, - slaveSpecs); - tables[index] = recordPtr->header.optionTable; - recordPtr->header.tkwin = tkwin; - recordPtr->windowPtr = NULL; - - result = Tk_InitOptions(interp, (char *) recordPtr, - recordPtr->header.optionTable, tkwin); - if (result == TCL_OK) { - result = Tk_SetOptions(interp, (char *) recordPtr, - recordPtr->header.optionTable, objc - 3, objv + 3, - tkwin, NULL, NULL); - if (result == TCL_OK) { - recordPtr->header.widgetCmd = Tcl_CreateObjCommand(interp, - Tcl_GetString(objv[2]), TrivialConfigObjCmd, - recordPtr, TrivialCmdDeletedProc); - Tk_CreateEventHandler(tkwin, StructureNotifyMask, - TrivialEventProc, recordPtr); - Tcl_SetObjResult(interp, objv[2]); - } else { - Tk_FreeConfigOptions((char *) recordPtr, - recordPtr->header.optionTable, tkwin); - } - } - if (result != TCL_OK) { - Tk_DestroyWindow(tkwin); - ckfree(recordPtr); - } - } - } - - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TrivialConfigObjCmd -- - * - * This command is used to test the configuration package. It only - * handles the "configure" and "cget" subcommands. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TrivialConfigObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int result = TCL_OK; - static const char *const options[] = { - "cget", "configure", "csave", NULL - }; - enum { - CGET, CONFIGURE, CSAVE - }; - Tcl_Obj *resultObjPtr; - int index, mask; - TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; - Tk_Window tkwin = headerPtr->tkwin; - Tk_SavedOptions saved; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, - sizeof(char *), "command", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - - Tcl_Preserve(clientData); - - switch (index) { - case CGET: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "option"); - result = TCL_ERROR; - goto done; - } - resultObjPtr = Tk_GetOptionValue(interp, (char *) clientData, - headerPtr->optionTable, objv[2], tkwin); - if (resultObjPtr != NULL) { - Tcl_SetObjResult(interp, resultObjPtr); - result = TCL_OK; - } else { - result = TCL_ERROR; - } - break; - case CONFIGURE: - if (objc == 2) { - resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData, - headerPtr->optionTable, NULL, tkwin); - if (resultObjPtr == NULL) { - result = TCL_ERROR; - } else { - Tcl_SetObjResult(interp, resultObjPtr); - } - } else if (objc == 3) { - resultObjPtr = Tk_GetOptionInfo(interp, (char *) clientData, - headerPtr->optionTable, objv[2], tkwin); - if (resultObjPtr == NULL) { - result = TCL_ERROR; - } else { - Tcl_SetObjResult(interp, resultObjPtr); - } - } else { - result = Tk_SetOptions(interp, (char *) clientData, - headerPtr->optionTable, objc - 2, objv + 2, - tkwin, NULL, &mask); - if (result == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(mask)); - } - } - break; - case CSAVE: - result = Tk_SetOptions(interp, (char *) clientData, - headerPtr->optionTable, objc - 2, objv + 2, - tkwin, &saved, &mask); - Tk_FreeSavedOptions(&saved); - if (result == TCL_OK) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(mask)); - } - break; - } - done: - Tcl_Release(clientData); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TrivialCmdDeletedProc -- - * - * This function is invoked when a widget command is deleted. If the - * widget isn't already in the process of being destroyed, this command - * destroys it. - * - * Results: - * None. - * - * Side effects: - * The widget is destroyed. - * - *---------------------------------------------------------------------- - */ - -static void -TrivialCmdDeletedProc( - ClientData clientData) /* Pointer to widget record for widget. */ -{ - TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; - Tk_Window tkwin = headerPtr->tkwin; - - if (tkwin != NULL) { - Tk_DestroyWindow(tkwin); - } else if (headerPtr->optionTable != NULL) { - /* - * This is a "new" object, which doesn't have a window, so we can't - * depend on cleaning up in the event function. Free its resources - * here. - */ - - Tk_FreeConfigOptions((char *) clientData, - headerPtr->optionTable, (Tk_Window) NULL); - Tcl_EventuallyFree(clientData, TCL_DYNAMIC); - } -} - -/* - *-------------------------------------------------------------- - * - * TrivialEventProc -- - * - * A dummy event proc. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get cleaned up. - * - *-------------------------------------------------------------- - */ - -static void -TrivialEventProc( - ClientData clientData, /* Information about window. */ - XEvent *eventPtr) /* Information about event. */ -{ - TrivialCommandHeader *headerPtr = (TrivialCommandHeader *) clientData; - - if (eventPtr->type == DestroyNotify) { - if (headerPtr->tkwin != NULL) { - Tk_FreeConfigOptions((char *) clientData, - headerPtr->optionTable, headerPtr->tkwin); - headerPtr->optionTable = NULL; - headerPtr->tkwin = NULL; - Tcl_DeleteCommandFromToken(headerPtr->interp, - headerPtr->widgetCmd); - } - Tcl_EventuallyFree(clientData, TCL_DYNAMIC); - } -} - -/* - *---------------------------------------------------------------------- - * - * TestfontObjCmd -- - * - * This function implements the "testfont" command, which is used to test - * TkFont objects. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestfontObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const options[] = {"counts", "subfonts", NULL}; - enum option {COUNTS, SUBFONTS}; - int index; - Tk_Window tkwin; - Tk_Font tkfont; - - tkwin = (Tk_Window) clientData; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, "option fontName"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObjStruct(interp, objv[1], options, - sizeof(char *), "command", 0, &index)!= TCL_OK) { - return TCL_ERROR; - } - - switch ((enum option) index) { - case COUNTS: - Tcl_SetObjResult(interp, - TkDebugFont(Tk_MainWindow(interp), Tcl_GetString(objv[2]))); - break; - case SUBFONTS: - tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); - if (tkfont == NULL) { - return TCL_ERROR; - } - TkpGetSubFonts(interp, tkfont); - Tk_FreeFont(tkfont); - break; - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ImageCreate -- - * - * This function is called by the Tk image code to create "test" images. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * The data structure for a new image is allocated. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -ImageCreate( - Tcl_Interp *interp, /* Interpreter for application containing - * image. */ - const char *name, /* Name to use for image. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument strings for options (doesn't - * include image name or type). */ - const Tk_ImageType *typePtr, /* Pointer to our type record (not used). */ - Tk_ImageMaster master, /* Token for image, to be used by us in later - * callbacks. */ - ClientData *clientDataPtr) /* Store manager's token for image here; it - * will be returned in later callbacks. */ -{ - TImageMaster *timPtr; - const char *varName; - int i; - - varName = "log"; - for (i = 0; i < objc; i += 2) { - if (strcmp(Tcl_GetString(objv[i]), "-variable") != 0) { - Tcl_AppendResult(interp, "bad option name \"", - Tcl_GetString(objv[i]), "\"", NULL); - return TCL_ERROR; - } - if ((i+1) == objc) { - Tcl_AppendResult(interp, "no value given for \"", - Tcl_GetString(objv[i]), "\" option", NULL); - return TCL_ERROR; - } - varName = Tcl_GetString(objv[i+1]); - } - - timPtr = ckalloc(sizeof(TImageMaster)); - timPtr->master = master; - timPtr->interp = interp; - timPtr->width = 30; - timPtr->height = 15; - timPtr->imageName = ckalloc(strlen(name) + 1); - strcpy(timPtr->imageName, name); - timPtr->varName = ckalloc(strlen(varName) + 1); - strcpy(timPtr->varName, varName); - Tcl_CreateObjCommand(interp, name, ImageObjCmd, timPtr, NULL); - *clientDataPtr = timPtr; - Tk_ImageChanged(master, 0, 0, 30, 15, 30, 15); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ImageObjCmd -- - * - * This function implements the commands corresponding to individual - * images. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Forces windows to be created. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -ImageObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - TImageMaster *timPtr = (TImageMaster *) clientData; - int x, y, width, height; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - if (strcmp(Tcl_GetString(objv[1]), "changed") == 0) { - if (objc != 8) { - Tcl_WrongNumArgs(interp, 1, objv, "changed x y width height" - " imageWidth imageHeight"); - return TCL_ERROR; - } - if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[4], &width) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[5], &height) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[6], &timPtr->width) != TCL_OK) - || (Tcl_GetIntFromObj(interp, objv[7], &timPtr->height) != TCL_OK)) { - return TCL_ERROR; - } - Tk_ImageChanged(timPtr->master, x, y, width, height, timPtr->width, - timPtr->height); - } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": must be changed", NULL); - return TCL_ERROR; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ImageGet -- - * - * This function is called by Tk to set things up for using a test image - * in a particular widget. - * - * Results: - * The return value is a token for the image instance, which is used in - * future callbacks to ImageDisplay and ImageFree. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static ClientData -ImageGet( - Tk_Window tkwin, /* Token for window in which image will be - * used. */ - ClientData clientData) /* Pointer to TImageMaster for image. */ -{ - TImageMaster *timPtr = (TImageMaster *) clientData; - TImageInstance *instPtr; - char buffer[100]; - XGCValues gcValues; - - sprintf(buffer, "%s get", timPtr->imageName); - Tcl_SetVar2(timPtr->interp, timPtr->varName, NULL, buffer, - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - - instPtr = ckalloc(sizeof(TImageInstance)); - instPtr->masterPtr = timPtr; - instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000"); - gcValues.foreground = instPtr->fg->pixel; - instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues); - return instPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ImageDisplay -- - * - * This function is invoked to redisplay part or all of an image in a - * given drawable. - * - * Results: - * None. - * - * Side effects: - * The image gets partially redrawn, as an "X" that shows the exact - * redraw area. - * - *---------------------------------------------------------------------- - */ - -static void -ImageDisplay( - ClientData clientData, /* Pointer to TImageInstance for image. */ - Display *display, /* Display to use for drawing. */ - Drawable drawable, /* Where to redraw image. */ - int imageX, int imageY, /* Origin of area to redraw, relative to - * origin of image. */ - int width, int height, /* Dimensions of area to redraw. */ - int drawableX, int drawableY) - /* Coordinates in drawable corresponding to - * imageX and imageY. */ -{ - TImageInstance *instPtr = (TImageInstance *) clientData; - char buffer[200 + TCL_INTEGER_SPACE * 6]; - - sprintf(buffer, "%s display %d %d %d %d %d %d", - instPtr->masterPtr->imageName, imageX, imageY, width, height, - drawableX, drawableY); - Tcl_SetVar2(instPtr->masterPtr->interp, instPtr->masterPtr->varName, NULL, - buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - if (width > (instPtr->masterPtr->width - imageX)) { - width = instPtr->masterPtr->width - imageX; - } - if (height > (instPtr->masterPtr->height - imageY)) { - height = instPtr->masterPtr->height - imageY; - } - XDrawRectangle(display, drawable, instPtr->gc, drawableX, drawableY, - (unsigned) (width-1), (unsigned) (height-1)); - XDrawLine(display, drawable, instPtr->gc, drawableX, drawableY, - (int) (drawableX + width - 1), (int) (drawableY + height - 1)); - XDrawLine(display, drawable, instPtr->gc, drawableX, - (int) (drawableY + height - 1), - (int) (drawableX + width - 1), drawableY); -} - -/* - *---------------------------------------------------------------------- - * - * ImageFree -- - * - * This function is called when an instance of an image is no longer - * used. - * - * Results: - * None. - * - * Side effects: - * Information related to the instance is freed. - * - *---------------------------------------------------------------------- - */ - -static void -ImageFree( - ClientData clientData, /* Pointer to TImageInstance for instance. */ - Display *display) /* Display where image was to be drawn. */ -{ - TImageInstance *instPtr = (TImageInstance *) clientData; - char buffer[200]; - - sprintf(buffer, "%s free", instPtr->masterPtr->imageName); - Tcl_SetVar2(instPtr->masterPtr->interp, instPtr->masterPtr->varName, NULL, - buffer, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - Tk_FreeColor(instPtr->fg); - Tk_FreeGC(display, instPtr->gc); - ckfree(instPtr); -} - -/* - *---------------------------------------------------------------------- - * - * ImageDelete -- - * - * This function is called to clean up a test image when an application - * goes away. - * - * Results: - * None. - * - * Side effects: - * Information about the image is deleted. - * - *---------------------------------------------------------------------- - */ - -static void -ImageDelete( - ClientData clientData) /* Pointer to TImageMaster for image. When - * this function is called, no more instances - * exist. */ -{ - TImageMaster *timPtr = (TImageMaster *) clientData; - char buffer[100]; - - sprintf(buffer, "%s delete", timPtr->imageName); - Tcl_SetVar2(timPtr->interp, timPtr->varName, NULL, buffer, - TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - - Tcl_DeleteCommand(timPtr->interp, timPtr->imageName); - ckfree(timPtr->imageName); - ckfree(timPtr->varName); - ckfree(timPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TestmakeexistObjCmd -- - * - * This function implements the "testmakeexist" command. It calls - * Tk_MakeWindowExist on each of its arguments to force the windows to be - * created. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Forces windows to be created. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestmakeexistObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - Tk_Window mainWin = (Tk_Window) clientData; - int i; - Tk_Window tkwin; - - for (i = 1; i < objc; i++) { - tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[i]), mainWin); - if (tkwin == NULL) { - return TCL_ERROR; - } - Tk_MakeWindowExist(tkwin); - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestmenubarObjCmd -- - * - * This function implements the "testmenubar" command. It is used to test - * the Unix facilities for creating space above a toplevel window for a - * menubar. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Changes menubar related stuff. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -#if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__)) -static int -TestmenubarObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ -#ifdef __UNIX__ - Tk_Window mainWin = (Tk_Window) clientData; - Tk_Window tkwin, menubar; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - - if (strcmp(Tcl_GetString(objv[1]), "window") == 0) { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "windows toplevel menubar"); - return TCL_ERROR; - } - tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), mainWin); - if (tkwin == NULL) { - return TCL_ERROR; - } - if (Tcl_GetString(objv[3])[0] == 0) { - TkUnixSetMenubar(tkwin, NULL); - } else { - menubar = Tk_NameToWindow(interp, Tcl_GetString(objv[3]), mainWin); - if (menubar == NULL) { - return TCL_ERROR; - } - TkUnixSetMenubar(tkwin, menubar); - } - } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": must be window", NULL); - return TCL_ERROR; - } - - return TCL_OK; -#else - Tcl_AppendResult(interp, "testmenubar is supported only under Unix", NULL); - return TCL_ERROR; -#endif -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TestmetricsObjCmd -- - * - * This function implements the testmetrics command. It provides a way to - * determine the size of various widget components. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -#if defined(_WIN32) || defined(MAC_OSX_TK) -static int -TestmetricsObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - char buf[TCL_INTEGER_SPACE]; - int val; - -#ifdef _WIN32 - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } -#else - Tk_Window tkwin = (Tk_Window) clientData; - TkWindow *winPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "option window"); - return TCL_ERROR; - } - - winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin); - if (winPtr == NULL) { - return TCL_ERROR; - } -#endif - - if (strcmp(Tcl_GetString(objv[1]), "cyvscroll") == 0) { -#ifdef _WIN32 - val = GetSystemMetrics(SM_CYVSCROLL); -#else - val = ((TkScrollbar *) winPtr->instanceData)->width; -#endif - } else if (strcmp(Tcl_GetString(objv[1]), "cxhscroll") == 0) { -#ifdef _WIN32 - val = GetSystemMetrics(SM_CXHSCROLL); -#else - val = ((TkScrollbar *) winPtr->instanceData)->width; -#endif - } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), - "\": must be cxhscroll or cyvscroll", NULL); - return TCL_ERROR; - } - sprintf(buf, "%d", val); - Tcl_AppendResult(interp, buf, NULL); - return TCL_OK; -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TestpropObjCmd -- - * - * This function implements the "testprop" command. It fetches and prints - * the value of a property on a window. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestpropObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - Tk_Window mainWin = (Tk_Window) clientData; - int result, actualFormat; - unsigned long bytesAfter, length, value; - Atom actualType, propName; - unsigned char *property, *p; - char *end; - Window w; - char buffer[30]; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "window property"); - return TCL_ERROR; - } - - w = strtoul(Tcl_GetString(objv[1]), &end, 0); - propName = Tk_InternAtom(mainWin, Tcl_GetString(objv[2])); - property = NULL; - result = XGetWindowProperty(Tk_Display(mainWin), - w, propName, 0, 100000, False, AnyPropertyType, - &actualType, &actualFormat, &length, - &bytesAfter, &property); - if ((result == Success) && (actualType != None)) { - if ((actualFormat == 8) && (actualType == XA_STRING)) { - for (p = property; ((unsigned long)(p-property)) < length; p++) { - if (*p == 0) { - *p = '\n'; - } - } - Tcl_SetObjResult(interp, Tcl_NewStringObj((/*!unsigned*/char*)property, -1)); - } else { - for (p = property; length > 0; length--) { - if (actualFormat == 32) { - value = *((long *) p); - p += sizeof(long); - } else if (actualFormat == 16) { - value = 0xffff & (*((short *) p)); - p += sizeof(short); - } else { - value = 0xff & *p; - p += 1; - } - sprintf(buffer, "0x%lx", value); - Tcl_AppendElement(interp, buffer); - } - } - } - if (property != NULL) { - XFree(property); - } - return TCL_OK; -} - -#if !(defined(_WIN32) || defined(MAC_OSX_TK) || defined(__CYGWIN__)) -/* - *---------------------------------------------------------------------- - * - * TestwrapperObjCmd -- - * - * This function implements the "testwrapper" command. It provides a way - * from Tcl to determine the extra window Tk adds in between the toplevel - * window and the window decorations. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestwrapperObjCmd( - ClientData clientData, /* Main window for application. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument strings. */ -{ - TkWindow *winPtr, *wrapperPtr; - Tk_Window tkwin; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "window"); - return TCL_ERROR; - } - - tkwin = (Tk_Window) clientData; - winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[1]), tkwin); - if (winPtr == NULL) { - return TCL_ERROR; - } - - wrapperPtr = TkpGetWrapperWindow(winPtr); - if (wrapperPtr != NULL) { - char buf[TCL_INTEGER_SPACE]; - - TkpPrintWindowId(buf, Tk_WindowId(wrapperPtr)); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); - } - return TCL_OK; -} -#endif - -/* - *---------------------------------------------------------------------- - * - * CustomOptionSet, CustomOptionGet, CustomOptionRestore, CustomOptionFree -- - * - * Handlers for object-based custom configuration options. See - * Testobjconfigcommand. - * - * Results: - * See user documentation for expected results from these functions. - * CustomOptionSet Standard Tcl Result. - * CustomOptionGet Tcl_Obj * containing value. - * CustomOptionRestore None. - * CustomOptionFree None. - * - * Side effects: - * Depends on the function. - * CustomOptionSet Sets option value to new setting. - * CustomOptionGet Creates a new Tcl_Obj. - * CustomOptionRestore Resets option value to original value. - * CustomOptionFree Free storage for internal rep of - * option. - * - *---------------------------------------------------------------------- - */ - -static int -CustomOptionSet( - ClientData clientData, - Tcl_Interp *interp, - Tk_Window tkwin, - Tcl_Obj **value, - char *recordPtr, - int internalOffset, - char *saveInternalPtr, - int flags) -{ - int objEmpty; - char *newStr, *string, *internalPtr; - - objEmpty = 0; - - if (internalOffset >= 0) { - internalPtr = recordPtr + internalOffset; - } else { - internalPtr = NULL; - } - - /* - * See if the object is empty. - */ - - if (value == NULL) { - objEmpty = 1; - CLANG_ASSERT(value); - } else if ((*value)->bytes != NULL) { - objEmpty = ((*value)->length == 0); - } else { - (void)Tcl_GetString(*value); - objEmpty = ((*value)->length == 0); - } - - if ((flags & TK_OPTION_NULL_OK) && objEmpty) { - *value = NULL; - } else { - string = Tcl_GetString(*value); - Tcl_UtfToUpper(string); - if (strcmp(string, "BAD") == 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("expected good value, got \"BAD\"", -1)); - return TCL_ERROR; - } - } - if (internalPtr != NULL) { - if (*value != NULL) { - string = Tcl_GetString(*value); - newStr = ckalloc((*value)->length + 1); - strcpy(newStr, string); - } else { - newStr = NULL; - } - *((char **) saveInternalPtr) = *((char **) internalPtr); - *((char **) internalPtr) = newStr; - } - - return TCL_OK; -} - -static Tcl_Obj * -CustomOptionGet( - ClientData clientData, - Tk_Window tkwin, - char *recordPtr, - int internalOffset) -{ - return (Tcl_NewStringObj(*(char **)(recordPtr + internalOffset), -1)); -} - -static void -CustomOptionRestore( - ClientData clientData, - Tk_Window tkwin, - char *internalPtr, - char *saveInternalPtr) -{ - *(char **)internalPtr = *(char **)saveInternalPtr; - return; -} - -static void -CustomOptionFree( - ClientData clientData, - Tk_Window tkwin, - char *internalPtr) -{ - if (*(char **)internalPtr != NULL) { - ckfree(*(char **)internalPtr); - } -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |