2080 lines
60 KiB
C
2080 lines
60 KiB
C
/*
|
||
* 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"
|
||
#define LOG_DISPLAY(drawable) TkTestLogDisplay(drawable)
|
||
#else
|
||
#define LOG_DISPLAY(drawable) 1
|
||
#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 model for a test image:
|
||
*/
|
||
|
||
typedef struct TImageModel {
|
||
Tk_ImageModel model; /* Tk's token for image model. */
|
||
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). */
|
||
} TImageModel;
|
||
|
||
/*
|
||
* The following data structure represents a particular use of a particular
|
||
* test image.
|
||
*/
|
||
|
||
typedef struct TImageInstance {
|
||
TImageModel *modelPtr; /* Pointer to model for image. */
|
||
XColor *fg; /* Foreground color for drawing in image. */
|
||
GC gc; /* Graphics context for drawing in image. */
|
||
Bool displayFailed; /* macOS display attempted out of drawRect. */
|
||
char buffer[200 + TCL_INTEGER_SPACE * 6]; /* message to log on display. */
|
||
} 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_ImageModel model,
|
||
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)
|
||
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 initialization for the Tk test suite extensions.
|
||
*
|
||
* 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)
|
||
Tcl_CreateObjCommand(interp, "testmetrics", TestmetricsObjCmd,
|
||
(ClientData) Tk_MainWindow(interp), NULL);
|
||
#elif !defined(__CYGWIN__) && !defined(MAC_OSX_TK)
|
||
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 */
|
||
|
||
/*
|
||
* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
TestbitmapObjCmd(
|
||
TCL_UNUSED(void *), /* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
TestborderObjCmd(
|
||
TCL_UNUSED(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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
TestcolorObjCmd(
|
||
TCL_UNUSED(void *), /* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
TestcursorObjCmd(
|
||
TCL_UNUSED(void *), /* 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 interpreters created by previous calls to "testnewapp" get
|
||
* deleted.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static int
|
||
TestdeleteappsObjCmd(
|
||
TCL_UNUSED(void *), /* Main window for application. */
|
||
TCL_UNUSED(Tcl_Interp *), /* Current interpreter. */
|
||
TCL_UNUSED(int), /* Number of arguments. */
|
||
TCL_UNUSED(Tcl_Obj *const *)) /* 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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;
|
||
|
||
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 = (TypesRecord *)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_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 = (ExtensionWidgetRecord *)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_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 = (ExtensionWidgetRecord *)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;
|
||
|
||
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 ContentRecord {
|
||
TrivialCommandHeader header;
|
||
Tcl_Obj *windowPtr;
|
||
} ContentRecord;
|
||
ContentRecord *recordPtr;
|
||
static const Tk_OptionSpec contentSpecs[] = {
|
||
{TK_OPTION_WINDOW, "-window", "window", "Window", ".bar",
|
||
Tk_Offset(ContentRecord, windowPtr), -1, TK_CONFIG_NULL_OK, NULL, 0},
|
||
{TK_OPTION_END, NULL, NULL, NULL, NULL, 0, 0, 0, NULL, 0}
|
||
};
|
||
tkwin = Tk_CreateWindowFromPath(interp,
|
||
(Tk_Window) clientData, Tcl_GetString(objv[2]), NULL);
|
||
|
||
if (tkwin == NULL) {
|
||
return TCL_ERROR;
|
||
}
|
||
Tk_SetClass(tkwin, "Test");
|
||
|
||
recordPtr = (ContentRecord *)ckalloc(sizeof(ContentRecord));
|
||
recordPtr->header.interp = interp;
|
||
recordPtr->header.optionTable = Tk_CreateOptionTable(interp,
|
||
contentSpecs);
|
||
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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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, 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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). */
|
||
TCL_UNUSED(const Tk_ImageType *), /* Pointer to our type record (not used). */
|
||
Tk_ImageModel model, /* 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. */
|
||
{
|
||
TImageModel *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 = (TImageModel *)ckalloc(sizeof(TImageModel));
|
||
timPtr->model = model;
|
||
timPtr->interp = interp;
|
||
timPtr->width = 30;
|
||
timPtr->height = 15;
|
||
timPtr->imageName = (char *)ckalloc(strlen(name) + 1);
|
||
strcpy(timPtr->imageName, name);
|
||
timPtr->varName = (char *)ckalloc(strlen(varName) + 1);
|
||
strcpy(timPtr->varName, varName);
|
||
Tcl_CreateObjCommand(interp, name, ImageObjCmd, timPtr, NULL);
|
||
*clientDataPtr = timPtr;
|
||
Tk_ImageChanged(model, 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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. */
|
||
{
|
||
TImageModel *timPtr = (TImageModel *)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->model, 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 TImageModel for image. */
|
||
{
|
||
TImageModel *timPtr = (TImageModel *)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 = (TImageInstance *)ckalloc(sizeof(TImageInstance));
|
||
instPtr->modelPtr = timPtr;
|
||
instPtr->fg = Tk_GetColor(timPtr->interp, tkwin, "#ff0000");
|
||
gcValues.foreground = instPtr->fg->pixel;
|
||
instPtr->gc = Tk_GetGC(tkwin, GCForeground, &gcValues);
|
||
instPtr->displayFailed = False;
|
||
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;
|
||
|
||
/*
|
||
* The purpose of the test image type is to track the calls to an image
|
||
* display proc and record the parameters passed in each call. On macOS a
|
||
* display proc must be run inside of the drawRect method of an NSView in
|
||
* order for the graphics operations to have any effect. To deal with
|
||
* this, whenever a display proc is called outside of any drawRect method
|
||
* it schedules a redraw of the NSView.
|
||
*
|
||
* In an attempt to work around this, each image instance maintains it own
|
||
* copy of the log message which gets written on the first call to the
|
||
* display proc. This usually means that the message created on macOS is
|
||
* the same as that created on other platforms. However it is possible
|
||
* for the messages to differ for other reasons, namely differences in
|
||
* how damage regions are computed.
|
||
*/
|
||
|
||
if (LOG_DISPLAY(drawable)) {
|
||
if (instPtr->displayFailed == False) {
|
||
|
||
/*
|
||
* Drawing is possible on the first call to DisplayImage.
|
||
* Log the message.
|
||
*/
|
||
|
||
sprintf(instPtr->buffer, "%s display %d %d %d %d",
|
||
instPtr->modelPtr->imageName, imageX, imageY, width, height);
|
||
}
|
||
Tcl_SetVar2(instPtr->modelPtr->interp, instPtr->modelPtr->varName,
|
||
NULL, instPtr->buffer,
|
||
TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
|
||
instPtr->displayFailed = False;
|
||
} else {
|
||
|
||
/*
|
||
* Drawing is not possible on the first call to DisplayImage.
|
||
* Save the message, but do not log it until the actual display.
|
||
*/
|
||
|
||
if (instPtr->displayFailed == False) {
|
||
sprintf(instPtr->buffer, "%s display %d %d %d %d",
|
||
instPtr->modelPtr->imageName, imageX, imageY, width, height);
|
||
}
|
||
instPtr->displayFailed = True;
|
||
}
|
||
if (width > (instPtr->modelPtr->width - imageX)) {
|
||
width = instPtr->modelPtr->width - imageX;
|
||
}
|
||
if (height > (instPtr->modelPtr->height - imageY)) {
|
||
height = instPtr->modelPtr->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->modelPtr->imageName);
|
||
Tcl_SetVar2(instPtr->modelPtr->interp, instPtr->modelPtr->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 TImageModel for image. When
|
||
* this function is called, no more instances
|
||
* exist. */
|
||
{
|
||
TImageModel *timPtr = (TImageModel *)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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
#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)
|
||
static int
|
||
TestmetricsObjCmd(
|
||
TCL_UNUSED(void *), /* 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;
|
||
|
||
if (objc < 2) {
|
||
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (strcmp(Tcl_GetString(objv[1]), "cyvscroll") == 0) {
|
||
val = GetSystemMetrics(SM_CYVSCROLL);
|
||
} else if (strcmp(Tcl_GetString(objv[1]), "cxhscroll") == 0) {
|
||
val = GetSystemMetrics(SM_CXHSCROLL);
|
||
} 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
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(
|
||
TCL_UNUSED(void *),
|
||
Tcl_Interp *interp,
|
||
TCL_UNUSED(Tk_Window),
|
||
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 = (char *)ckalloc((*value)->length + 1);
|
||
strcpy(newStr, string);
|
||
} else {
|
||
newStr = NULL;
|
||
}
|
||
*((char **) saveInternalPtr) = *((char **) internalPtr);
|
||
*((char **) internalPtr) = newStr;
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
static Tcl_Obj *
|
||
CustomOptionGet(
|
||
TCL_UNUSED(void *),
|
||
TCL_UNUSED(Tk_Window),
|
||
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:
|
||
*/
|