/*
* tkoWidget.h --
*
* This file contains the tko widget class.
*
* Copyright (c) 2019 Rene Zaumseil
*
*/
#include "tcl.h"
#include "tclOO.h"
#include "tk.h"
#include "tkInt.h"
#include "tkoWidget.h"
/*
* Widget structure data used in objects.
*/
typedef struct tkoWidget {
Tcl_Interp *interp; /* Interpreter associated with widget. */
Tcl_Object object; /* our own object */
Tk_Window tkWin; /* Window that embodies the canvas. NULL means
* that the window has been destroyed but the
* data structures haven't yet been cleaned
* up.*/
Tcl_Obj *myCmd; /* Objects "my" command. Needed to call internal methods. */
Tcl_Command widgetCmd; /* Token for canvas's widget command. */
Tcl_Obj *optionsArray; /* Name of option array variable */
Tcl_HashTable optionsTable; /* Hash table containing all used options */
} tkoWidget;
/*
* Widget option.
*/
typedef struct WidgetOption {
Tcl_Obj *option; /* Name of option */
Tcl_Obj *dbname; /* Database name or name of synonym option */
Tcl_Obj *dbclass; /* Class name or NULL for synonym options */
Tcl_Obj *defvalue; /* Default value from initialization */
Tcl_Obj *value; /* Contain last known value of option */
int flags; /* see flags in struct tkoWidgetOptionDefine */
} WidgetOption;
/*
* Static tcl objects.
*/
Tk_Uid TkoUid_class = NULL;
tkoObj TkoObj =
{ NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
/*
* Methods
*/
static int WidgetConstructor(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
static int WidgetDestructor(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
static int WidgetMethod_cget(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
static int WidgetMethod_configure(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
static int WidgetMethod_tko_configure(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
/*
* Functions
*/
static char *WidgetOptionTrace(
ClientData clientData,
Tcl_Interp * interp,
const char *name1,
const char *name2,
int flags);
static void WidgetOptionDelEntry(
Tcl_HashEntry * entry);
static void WidgetEventProc(
ClientData clientData,
XEvent * eventPtr);
static int WidgetOptionAdd(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option,
Tcl_Obj * dbname,
Tcl_Obj * dbclass,
Tcl_Obj * defvalue,
Tcl_Obj * flags,
Tcl_Obj * value,
int initmode);
static int WidgetOptionConfigure(
Tcl_Interp * interp,
tkoWidget * widget,
int objc,
Tcl_Obj * const objv[]);
static int WidgetOptionDel(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option);
static int WidgetOptionGet(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option);
static int WidgetOptionSet(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option,
Tcl_Obj * value);
static void WidgetMetaDestroy(
tkoWidget * widget);
static void WidgetMetaDelete(
ClientData clientData);
static int WidgetMethod_(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[]);
/*
* tkoWidgetMeta --
*/
Tcl_ObjectMetadataType tkoWidgetMeta = {
TCL_OO_METADATA_VERSION_CURRENT,
"tkoWidgetMeta",
WidgetMetaDelete,
NULL
};
/*
* widgetMethods --
*
*/
static Tcl_MethodType widgetMethods[] = {
{TCL_OO_METHOD_VERSION_CURRENT, NULL, WidgetConstructor, NULL, NULL},
{TCL_OO_METHOD_VERSION_CURRENT, NULL, WidgetDestructor, NULL, NULL},
{TCL_OO_METHOD_VERSION_CURRENT, "cget", WidgetMethod_cget, NULL, NULL},
{TCL_OO_METHOD_VERSION_CURRENT, "configure", WidgetMethod_configure, NULL,
NULL},
{-1, NULL, NULL, NULL, NULL},
{TCL_OO_METHOD_VERSION_CURRENT, "_tko_configure",
WidgetMethod_tko_configure, NULL, NULL},
{-1, NULL, NULL, NULL, NULL}
};
/*
* TkoWidgetWindow --
*
* Results:
*
* Side effects:
*/
Tk_Window *
TkoWidgetWindow(
Tcl_Object object)
{
tkoWidget *widget = (tkoWidget *) Tcl_ObjectGetMetadata(object, &tkoWidgetMeta);
if(widget)
return &widget->tkWin;
return NULL;
}
/*
* TkoWidgetOptionVar --
*
* Results:
*
* Side effects:
*/
Tcl_Obj *
TkoWidgetOptionVar(
Tcl_Object object)
{
tkoWidget *widget = (tkoWidget *) Tcl_ObjectGetMetadata(object, &tkoWidgetMeta);
if(widget)
return widget->optionsArray;
return NULL;
}
/*
* TkoWidgetClassDefine --
*
* Results:
*
* Side effects:
*/
int
TkoWidgetClassDefine(
Tcl_Interp * interp,
Tcl_Class clazz,
Tcl_Obj * classname,
const Tcl_MethodType * methods,
tkoWidgetOptionDefine * options)
{
Tcl_Obj *listPtr;
int i;
Tcl_Obj *option;
Tcl_MethodType *methodPtr;
Tcl_Obj *myObjv[6];
Tcl_Obj *retPtr;
Tcl_Obj *tmpObj;
if(classname == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing class name"));
return TCL_ERROR;
}
/*
* Add methods
*/
if(methods) {
/* constructor */
if(methods[0].name == NULL && methods[0].callProc) {
Tcl_ClassSetConstructor(interp, clazz,
Tcl_NewMethod(interp, clazz, NULL, 1, &methods[0], NULL));
}
/* destructor */
if(methods[1].name == NULL && methods[1].callProc) {
Tcl_ClassSetDestructor(interp, clazz,
Tcl_NewMethod(interp, clazz, NULL, 1, &methods[1], NULL));
}
/* public */
for(i = 2; methods[i].name != NULL; i++) {
tmpObj = Tcl_NewStringObj(methods[i].name, -1);
Tcl_IncrRefCount(tmpObj);
Tcl_NewMethod(interp, clazz, tmpObj, 1, &methods[i], NULL);
Tcl_DecrRefCount(tmpObj);
}
i++;
/* private */
for(; methods[i].name != NULL; i++) {
tmpObj = Tcl_NewStringObj(methods[i].name, -1);
Tcl_IncrRefCount(tmpObj);
Tcl_NewMethod(interp, clazz, tmpObj, 0, &methods[i], NULL);
Tcl_DecrRefCount(tmpObj);
}
}
/*
*Add options
*/
if(options) {
/*
* Option definitions will be saved in the tko::options array variable.
* All options of a class are saved as a list under tko::option(classname)
* Here we ensure this variable exists and is a proper list.
*/
retPtr =
Tcl_ObjGetVar2(interp, TkoObj.tko_options, classname,
TCL_GLOBAL_ONLY);
if(retPtr == NULL) {
retPtr = Tcl_NewObj();
Tcl_IncrRefCount(retPtr);
} else {
if(Tcl_ListObjLength(interp, retPtr, &i) != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("::tko::options(%s) variable is not list",
Tcl_GetString(classname)));
return TCL_ERROR;
}
retPtr = Tcl_DuplicateObj(retPtr);
Tcl_IncrRefCount(retPtr);
}
/* Loop over all option definitions */
for(i = 0;; i++) {
if(options[i].option == NULL)
break; /* end of options */
if(options[i].dbname == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("wrong option definition: %d", i));
goto error;
}
listPtr = Tcl_NewObj();
option = Tcl_NewStringObj(options[i].option, -1);
Tcl_IncrRefCount(option);
Tcl_ListObjAppendElement(interp, listPtr, option);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(options[i].dbname, -1));
/* synonym option, ignore rest */
if(options[i].dbclass == NULL) {
Tcl_ListObjAppendElement(interp, retPtr, listPtr);
Tcl_DecrRefCount(option);
continue;
}
/* normal option */
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(options[i].dbclass, -1));
if(options[i].defvalue == NULL) {
Tcl_ListObjAppendElement(interp, listPtr, TkoObj.empty);
} else {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(options[i].defvalue, -1));
}
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewIntObj(options[i].flags));
Tcl_ListObjAppendElement(interp, retPtr, listPtr);
/*
* Now we create the necessary -option method if provided.
* If given we use the code provided in the proc body.
* Or we create the -option method with the given method.
* Or we use the internal implementation of a given type.
* If none of the above are provided it is up to the caller
* to create the necessary -option method.
*/
if(options[i].proc != NULL) {
myObjv[0] = TkoObj.oo_define;
myObjv[1] = classname;
myObjv[2] = TkoObj.method;
myObjv[3] = option;
myObjv[4] = TkoObj.empty;
myObjv[5] = Tcl_NewStringObj(options[i].proc, -1);
Tcl_IncrRefCount(myObjv[5]);
if(Tcl_EvalObjv(interp, 6, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_DecrRefCount(myObjv[5]);
Tcl_DecrRefCount(option);
goto error;
}
Tcl_DecrRefCount(myObjv[5]);
} else if(options[i].method != NULL) {
methodPtr = (Tcl_MethodType *) ckalloc(sizeof(Tcl_MethodType));
methodPtr->version = TCL_OO_METHOD_VERSION_CURRENT;
methodPtr->name = options[i].option;
methodPtr->callProc = options[i].method;
methodPtr->deleteProc = NULL;
methodPtr->cloneProc = NULL;
Tcl_NewMethod(interp, clazz, option, 0, methodPtr, NULL);
} else if(options[i].type >= 0) {
if (options[i].optionPtr == NULL) {
options[i].optionPtr = option;
Tcl_IncrRefCount(option);
}
methodPtr = (Tcl_MethodType *) ckalloc(sizeof(Tcl_MethodType));
methodPtr->version = TCL_OO_METHOD_VERSION_CURRENT;
methodPtr->name = options[i].option;
methodPtr->callProc = WidgetMethod_;
methodPtr->deleteProc = NULL;
methodPtr->cloneProc = NULL;
Tcl_NewMethod(interp, clazz, option, 0, methodPtr,
(ClientData) & options[i]);
}
Tcl_DecrRefCount(option);
}
Tcl_ObjSetVar2(interp, TkoObj.tko_options, classname, retPtr,
TCL_GLOBAL_ONLY);
Tcl_SetObjResult(interp, retPtr);
}
return TCL_OK;
error:
Tcl_DecrRefCount(retPtr);
return TCL_ERROR;
}
/*
* Tko_Init --
*
* Results:
*
* Side effects:
*/
int
Tko_Init(
Tcl_Interp * interp /* Tcl interpreter. */)
{
/* Needed oo extension */
if(Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
if(Tko_WidgetInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if(Tko_FrameInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if(Tko_VectorInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if(Tko_GraphInit(interp) != TCL_OK) {
return TCL_ERROR;
}
if(Tko_PathInit(interp) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Tko_WidgetInit --
*
* Results:
*
* Side effects:
*/
int
Tko_WidgetInit(
Tcl_Interp * interp /* Tcl interpreter. */)
{
Tcl_Class clazz;
Tcl_Object object;
/* Create class like tk command and remove oo functions from widget commands */
static const char *initScript =
"namespace eval ::tko {variable options}\n"
"array set ::tko::options {}\n"
"::oo::class create ::tko::widget {\n"
" variable tko\n"
" self unexport new destroy\n"
" unexport new create destroy\n"
"}\n"
"set ::tko::unknown [list self method unknown args {\n"
" if {[set w [lindex $args 0]] eq {}} {return -code error \"wrong # args: should be \\\"[self] pathName ?-option value ...?\\\"\"}\n"
" uplevel #0 [list [self] create $w {} [lrange $args 1 end]]\n"
" $w configure init\n"
" return $w\n"
"}]";
/*
* Internal variables and constants.
*/
TkoUid_class = Tk_GetUid("-class");
if(TkoObj.empty == NULL) {
Tcl_IncrRefCount((TkoObj.empty = Tcl_NewStringObj("", -1)));
Tcl_IncrRefCount((TkoObj.point = Tcl_NewStringObj(".", -1)));
Tcl_IncrRefCount((TkoObj.next = Tcl_NewStringObj("next", -1)));
Tcl_IncrRefCount((TkoObj.uplevel = Tcl_NewStringObj("::uplevel", -1)));
Tcl_IncrRefCount((TkoObj.oo_define =
Tcl_NewStringObj("::oo::define", -1)));
Tcl_IncrRefCount((TkoObj.oo_objdefine =
Tcl_NewStringObj("::oo::objdefine", -1)));
Tcl_IncrRefCount((TkoObj.method = Tcl_NewStringObj("method", -1)));
Tcl_IncrRefCount((TkoObj._tko_configure =
Tcl_NewStringObj("_tko_configure", -1)));
Tcl_IncrRefCount((TkoObj.tko = Tcl_NewStringObj("::tko", -1)));
Tcl_IncrRefCount((TkoObj.tko_options =
Tcl_NewStringObj("::tko::options", -1)));
Tcl_IncrRefCount((TkoObj.lsort = Tcl_NewStringObj("::lsort", -1)));
Tcl_IncrRefCount((TkoObj.tko_widget =
Tcl_NewStringObj("::tko::widget", -1)));
Tcl_IncrRefCount((TkoObj.tko_frame =
Tcl_NewStringObj("::tko::frame", -1)));
Tcl_IncrRefCount((TkoObj.tko_labelframe =
Tcl_NewStringObj("::tko::labelframe", -1)));
Tcl_IncrRefCount((TkoObj.tko_toplevel =
Tcl_NewStringObj("::tko::toplevel", -1)));
Tcl_IncrRefCount((TkoObj.path = Tcl_NewStringObj("::path", -1)));
Tcl_IncrRefCount((TkoObj.graph = Tcl_NewStringObj("::graph", -1)));
Tcl_IncrRefCount((TkoObj._screen = Tcl_NewStringObj("-screen", -1)));
Tcl_IncrRefCount((TkoObj._labelwidget =
Tcl_NewStringObj("-labelwidget", -1)));
Tcl_IncrRefCount((TkoObj._0 = Tcl_NewIntObj(0)));
Tcl_IncrRefCount((TkoObj._1 = Tcl_NewIntObj(1)));
}
/* Create widget class. */
if(Tcl_Eval(interp, initScript) != TCL_OK) {
return TCL_ERROR;
}
/* Get class object */
if((object = Tcl_GetObjectFromObj(interp, TkoObj.tko_widget)) == NULL
|| (clazz = Tcl_GetObjectAsClass(object)) == NULL) {
return TCL_ERROR;
}
/*
* Add methods and options
*/
if(TkoWidgetClassDefine(interp, clazz, Tcl_GetObjectName(interp, object),
widgetMethods, NULL) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* WidgetConstructor --
*
* class create path optiondefs optionargs
* -screen "" -- special arg to place toplevel widgets
*
* Results:
*
* Side effects:
*/
static int
WidgetConstructor(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{
Tcl_Object object;
tkoWidget *widget;
Tk_Window tkWin;
Tcl_Namespace *nsPtr;
Tcl_Obj *argPtr;
int argSize;
Tcl_Obj **optionObjv;
int optionObjc;
Tcl_Obj **argObjv;
int argObjc;
int i;
Tcl_Obj *dbclass;
Tcl_Obj *defvalue;
Tcl_Obj *flags;
Tcl_Obj *value;
const char *screenName = NULL;
Tcl_Obj *win;
char *ch = NULL;
int length;
/* Get current object. Should not fail? */
if((object = Tcl_ObjectContextObject(context)) == NULL) {
return TCL_ERROR;
}
/* Check objv[] arguments: ... optionlist arglist */
if(objc - Tcl_ObjectContextSkippedArgs(context) != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "optionlist arglist");
return TCL_ERROR;
}
/* check arguments */
if(Tcl_ListObjGetElements(interp, objv[objc - 2], &optionObjc,
&optionObjv) != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("could not get list of options"));
return TCL_ERROR;
}
argPtr = objv[objc - 1];
if(Tcl_DictObjSize(interp, argPtr, &argSize) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not get arglist"));
return TCL_ERROR;
}
/* Check on -screen option indicating creation of toplevel window
*/
Tcl_DictObjGet(interp, argPtr, TkoObj._screen, &value);
if(value) {
for(i = 0; i < optionObjc; i++) {
Tcl_ListObjGetElements(interp, optionObjv[i], &argObjc, &argObjv);
if(strcmp(Tcl_GetString(argObjv[0]), "-screen") == 0) {
screenName = Tcl_GetString(value);
break;
}
}
}
/* check widget name */
if((win = Tcl_GetObjectName(interp, object)) == NULL
|| (ch = TclGetStringFromObj(win, &length)) == NULL
|| length < 4 || ch[0] != ':' || ch[1] != ':' || ch[2] != '.') {
if (ch) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("no pathName"));
}
else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong pathName: %s", ch));
}
return TCL_ERROR;
}
tkWin =
Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), &ch[2],
screenName);
if(tkWin == NULL) {
return TCL_ERROR;
}
Tk_MakeWindowExist(tkWin);
widget = (tkoWidget *)ckalloc(sizeof(tkoWidget));
widget->interp = interp;
widget->object = object;
widget->tkWin = tkWin;
widget->widgetCmd = Tcl_GetObjectCommand(object);
Tcl_InitHashTable(&widget->optionsTable, TCL_ONE_WORD_KEYS);
widget->optionsArray = NULL;
/* Create option array variable */
nsPtr = Tcl_GetObjectNamespace(object);
widget->optionsArray = Tcl_NewStringObj(nsPtr->fullName, -1);
Tcl_IncrRefCount(widget->optionsArray);
Tcl_AppendToObj(widget->optionsArray, "::tko", -1);
/* set tko(.) to name of widget */
win = Tcl_NewStringObj(&ch[2], length - 2);
Tcl_IncrRefCount(win);
if(Tcl_ObjSetVar2(interp, widget->optionsArray, TkoObj.point, win,
TCL_GLOBAL_ONLY) == NULL) {
Tcl_DecrRefCount(win);
goto error;
}
Tcl_DecrRefCount(win);
/* Create my command */
widget->myCmd = Tcl_NewStringObj(nsPtr->fullName, -1);
Tcl_IncrRefCount(widget->myCmd);
Tcl_AppendToObj(widget->myCmd, "::my", -1);
Tcl_ObjectSetMetadata(object, &tkoWidgetMeta, (ClientData) widget);
/*
* Add options
*/
for(i = 0; i < optionObjc; i++) {
Tcl_ListObjGetElements(interp, optionObjv[i], &argObjc, &argObjv);
dbclass = defvalue = flags = value = NULL;
switch (argObjc) {
case 2:
break;
case 3:
dbclass = argObjv[2];
break;
case 4:
dbclass = argObjv[2];
defvalue = argObjv[3];
break;
case 5:
dbclass = argObjv[2];
defvalue = argObjv[3];
flags = argObjv[4];
break;
default:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong option def: %s",
Tcl_GetString(optionObjv[i])));
goto error;
}
Tcl_DictObjGet(interp, argPtr, argObjv[0], &value);
if(value) {
Tcl_IncrRefCount(value);
Tcl_DictObjRemove(interp, argPtr, argObjv[0]);
argSize--;
}
if(WidgetOptionAdd(interp, widget, argObjv[0], argObjv[1],
dbclass, defvalue, flags, value, 1) != TCL_OK) {
goto error;
}
}
if(argSize) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown options: %s",
Tcl_GetString(argPtr)));
goto error;
}
Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL,
TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget);
Tk_CreateEventHandler(tkWin, StructureNotifyMask,
WidgetEventProc, (ClientData) widget);
return TCL_OK;
error:
Tcl_DeleteCommandFromToken(interp, Tcl_GetObjectCommand(object));
return TCL_ERROR;
}
/*
* WidgetDestructor --
*
* Results:
*
* Side effects:
*/
static int
WidgetDestructor(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{
Tcl_Object object;
tkoWidget *widget;
/* Get current object. Should not fail? */
if((object = Tcl_ObjectContextObject(context)) == NULL)
return TCL_ERROR;
if((widget =
(tkoWidget *) Tcl_ObjectGetMetadata(object,
&tkoWidgetMeta)) == NULL)
return TCL_ERROR;
Tcl_Preserve(widget);
if(widget->tkWin) {
Tk_DeleteEventHandler(widget->tkWin, StructureNotifyMask,
WidgetEventProc, (ClientData) widget);
Tk_DestroyWindow(widget->tkWin);
widget->tkWin = NULL;
}
Tcl_ObjectSetMetadata(object, &tkoWidgetMeta, NULL);
Tcl_Release(widget);
return TCL_OK;
}
/*
* WidgetMetaDestroy --
*
* Results:
*
* Side effects:
*/
static void
WidgetMetaDestroy(
tkoWidget * widget)
{
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
entryPtr = Tcl_FirstHashEntry(&widget->optionsTable, &search);
while(entryPtr != NULL) {
WidgetOptionDelEntry(entryPtr);
entryPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&widget->optionsTable);
if(widget->optionsArray != NULL) {
Tcl_DecrRefCount((widget->optionsArray));
widget->optionsArray = NULL;
}
if(widget->myCmd) {
Tcl_DecrRefCount(widget->myCmd);
widget->myCmd = NULL;
}
ckfree(widget);
}
/*
* WidgetEventProc --
*
* This function is invoked by the Tk dispatcher for various events on
* canvases.
*
* Results:
* None.
*
* Side effects:
* When the window gets deleted, internal structures get cleaned up.
* When it gets exposed, it is redisplayed.
*/
static void
WidgetEventProc(
ClientData clientData, /* Information about window. */
XEvent * eventPtr)
{ /* Information about event. */
tkoWidget *widget = (tkoWidget *) clientData;
if(eventPtr->type == DestroyNotify) {
if(widget->tkWin) {
Tk_DeleteEventHandler(widget->tkWin, StructureNotifyMask,
WidgetEventProc, widget);
Tk_DestroyWindow(widget->tkWin);
widget->tkWin = NULL;
Tcl_DeleteCommandFromToken(widget->interp, widget->widgetCmd);
}
}
}
/*
* WidgetMethod_cget --
*
* cget "-option"
*
* Results:
*
* Side effects:
*/
static int
WidgetMethod_cget(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{
Tcl_Object object;
tkoWidget *widget; /* widget. */
int skip;
if((object = Tcl_ObjectContextObject(context)) == NULL)
return TCL_ERROR;
if((widget =
(tkoWidget *) Tcl_ObjectGetMetadata(object,
&tkoWidgetMeta)) == NULL)
return TCL_ERROR;
skip = Tcl_ObjectContextSkippedArgs(context);
if(objc - skip != 1) {
Tcl_WrongNumArgs(interp, skip, objv, "option");
return TCL_ERROR;
}
return WidgetOptionGet(interp, widget, objv[skip]);
}
/*
* WidgetMethod_configure --
*
* configure
* configure "-option"
* configure "-option value .."
* configure "add option dbname dbclass ?default?"
* configure "del option"
* configure "after"
*
* set tk(-option) -> WidgetTraceOption() -> my -option $v ..
* Results:
*
* Side effects:
*/
static int
WidgetMethod_configure(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{
int result, index;
Tcl_Object object;
tkoWidget *widget; /* widget. */
int skip;
Tcl_Obj *myObjv[2];
static const char *const commandNames[] =
{ "init", "optionadd", "optiondel", "optionhide", "optionshow", "optionvar", NULL };
enum command {
COMMAND_INIT, COMMAND_OPTIONADD, COMMAND_OPTIONDEL,
COMMAND_OPTIONHIDE, COMMAND_OPTIONSHOW,
COMMAND_OPTIONVAR
};
Tcl_Obj *dbclass = NULL;
Tcl_Obj *defvalue = NULL;
Tcl_Obj *flags = NULL;
Tcl_HashSearch search;
Tcl_HashEntry *entryPtr;
WidgetOption *optionPtr;
Tcl_Obj *retPtr;
Tcl_Obj *listPtr;
if((object = Tcl_ObjectContextObject(context)) == NULL
|| (widget = (tkoWidget *)Tcl_ObjectGetMetadata(object,
&tkoWidgetMeta)) == NULL) {
return TCL_ERROR;
}
skip = Tcl_ObjectContextSkippedArgs(context);
if(widget->tkWin == NULL) {
return TCL_ERROR;
}
/* configure */
if(objc - skip == 0) {
retPtr = Tcl_NewObj();
entryPtr = Tcl_FirstHashEntry(&widget->optionsTable, &search);
while(entryPtr != NULL) { /* TODO Tcl_DuplicateObj()? */
optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr);
entryPtr = Tcl_NextHashEntry(&search);
/* hidden option, not visible in configure method */
if (optionPtr->flags&TKO_OPTION_HIDE) continue;
listPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbname);
if(optionPtr->dbclass != NULL) {
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbclass);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->defvalue);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->value);
}
Tcl_ListObjAppendElement(interp, retPtr, listPtr);
}
/* Return sorted list */
myObjv[0] = TkoObj.lsort;
myObjv[1] = retPtr;
return (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL));
}
/* configure "-option ?value? .." */
if(Tcl_GetString(objv[skip])[0] == '-') {
if(objc - skip == 1) { /* configure -option */
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(objv[skip])));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option \"%s\"",
Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr);
/* hidden option, not visible in configure method */
if (optionPtr->flags&TKO_OPTION_HIDE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"",
Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
if(optionPtr->dbclass == NULL) {
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(optionPtr->dbname)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"",
Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr);
if(optionPtr->dbclass == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"",
Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
}
listPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbname);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbclass);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->defvalue);
Tcl_ListObjAppendElement(interp, listPtr, optionPtr->value);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
if((objc - skip) % 2 == 0) { /* configure "-option value .." */
return WidgetOptionConfigure(interp, widget, objc - skip,
&objv[skip]);
}
Tcl_WrongNumArgs(interp, skip, objv, "?-option value ..?");
return TCL_ERROR;
}
/* configure "command .." */
result =
Tcl_GetIndexFromObj(interp, objv[skip], commandNames, "option", 0,
&index);
if(result != TCL_OK) {
return result;
}
switch (index) {
case COMMAND_INIT:
// collect all not readonly options and configure
Tcl_Preserve(widget);
myObjv[0] = widget->myCmd;
entryPtr = Tcl_FirstHashEntry(&widget->optionsTable, &search);
while (entryPtr != NULL) {
optionPtr = Tcl_GetHashValue(entryPtr);
entryPtr = Tcl_NextHashEntry(&search);
if (optionPtr->dbclass == NULL) { /* synonym option */
if (optionPtr->value) {
Tcl_ObjSetVar2(interp, widget->optionsArray,
optionPtr->dbname, optionPtr->value, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(optionPtr->value);
optionPtr->value = NULL;
}
}
else { /* normal option */
if ((optionPtr->flags & TKO_OPTION_READONLY) == 0) {
myObjv[1] = optionPtr->option;
if (Tcl_EvalObjv(interp, 2, myObjv,
TCL_EVAL_GLOBAL) != TCL_OK) {
retPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(retPtr);
Tcl_Release(widget);
Tcl_DeleteCommandFromToken(interp, widget->widgetCmd);
Tcl_SetObjResult(interp, retPtr);
Tcl_DecrRefCount(retPtr);
return TCL_ERROR;
}
}
}
}
myObjv[1] = TkoObj._tko_configure;
if (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) {
retPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(retPtr);
Tcl_Release(widget);
Tcl_DeleteCommandFromToken(interp, widget->widgetCmd);
Tcl_SetObjResult(interp, retPtr);
Tcl_DecrRefCount(retPtr);
return TCL_ERROR;
}
Tcl_Release(widget);
return TCL_OK;
case COMMAND_OPTIONADD:
dbclass = NULL;
defvalue = NULL;
flags = NULL;
if(objc - skip == 3) { /* configure add option dbname */
;
} else if(objc - skip == 4) { /* configure add option dbname dbclass */
dbclass = objv[skip + 3];
} else if(objc - skip == 5) { /* configure add option dbname dbclass defvalue */
dbclass = objv[skip + 3];
defvalue = objv[skip + 4];
} else if(objc - skip == 6) { /* configure add option dbname dbclass defvalue flags */
dbclass = objv[skip + 3];
defvalue = objv[skip + 4];
flags = objv[skip + 5];
} else {
Tcl_WrongNumArgs(interp, skip + 1, objv,
"option ?synonym?|?dbname dbclass ?default? ?flags??");
return TCL_ERROR;
}
return (WidgetOptionAdd(interp, widget, objv[skip + 1], objv[skip + 2],
dbclass, defvalue, flags, NULL, 0));
case COMMAND_OPTIONDEL:
if(objc - skip == 2) {
return (WidgetOptionDel(interp, widget, objv[skip + 1]));
}
Tcl_WrongNumArgs(interp, skip + 1, objv, "option");
return TCL_ERROR;
case COMMAND_OPTIONHIDE:
/* no further args, return hidden options */
if (objc - skip == 1) {
retPtr = Tcl_NewObj();
entryPtr = Tcl_FirstHashEntry(&widget->optionsTable, &search);
while (entryPtr != NULL) {
optionPtr = Tcl_GetHashValue(entryPtr);
entryPtr = Tcl_NextHashEntry(&search);
if (optionPtr->flags&TKO_OPTION_HIDE) {
Tcl_ListObjAppendElement(interp, retPtr, optionPtr->option);
}
}
/* Return sorted list */
myObjv[0] = TkoObj.lsort;
myObjv[1] = retPtr;
return (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL));
/* hide given options */
} else {
skip++;
while (skip < objc) {
entryPtr = Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(objv[skip])));
if (entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
optionPtr->flags |= TKO_OPTION_HIDE;
skip++;
}
return TCL_OK;
}
case COMMAND_OPTIONSHOW:
/* no further args, return configure'able options */
if (objc - skip == 1) {
retPtr = Tcl_NewObj();
entryPtr = Tcl_FirstHashEntry(&widget->optionsTable, &search);
while (entryPtr != NULL) {
optionPtr = Tcl_GetHashValue(entryPtr);
entryPtr = Tcl_NextHashEntry(&search);
if ((optionPtr->flags & TKO_OPTION_HIDE) == 0) {
Tcl_ListObjAppendElement(interp, retPtr, optionPtr->option);
}
}
/* Return sorted list */
myObjv[0] = TkoObj.lsort;
myObjv[1] = retPtr;
return (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL));
/* make given options configure'able */
} else {
skip++;
while (skip < objc) {
entryPtr = Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(objv[skip])));
if (entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(objv[skip])));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
optionPtr->flags &= ~TKO_OPTION_HIDE;
skip++;
}
return TCL_OK;
}
case COMMAND_OPTIONVAR:
if(objc - skip == 1) {
Tcl_SetObjResult(interp, widget->optionsArray);
return TCL_OK;
}
Tcl_WrongNumArgs(interp, skip + 1, objv, "");
return TCL_ERROR;
}
return TCL_ERROR; /* supress compiler warning */
}
/*
* WidgetOptionAdd --
*
* Results:
*
* Side effects:
*/
static int
WidgetOptionAdd(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option,
Tcl_Obj * dbname,
Tcl_Obj * dbclass,
Tcl_Obj * defvalue,
Tcl_Obj * flags,
Tcl_Obj * value,
int initmode)
{
Tcl_HashEntry *entryPtr;
WidgetOption *optionPtr;
Tk_Uid valueUid;
int isNew;
Tk_Uid optionUid;
Tk_Uid dbnameUid;
Tk_Uid dbclassUid;
int intFlags;
int readonly;
Tcl_Obj *myObjv[2];
const char *ch;
int traceadd = 0; /* if not 0 then readd trace on array variable */
if(option == NULL || (ch = Tcl_GetString(option))[0] != '-') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("missing or wrong option",
-1));
return TCL_ERROR;
}
if(dbname == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("missing dbname for option \"%s\"", ch));
return TCL_ERROR;
}
/* synonym option check */
if(dbclass == NULL) {
if(Tcl_GetString(dbname)[0] != '-') {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("wrong synonym name for option \"%s\"", ch));
return TCL_ERROR;
}
}
/* int flag */
intFlags = 0;
if(flags != NULL && Tcl_GetIntFromObj(interp, flags, &intFlags) != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("wrong flags \"%s\" for option \"%s\"",
Tcl_GetString(flags), ch));
return TCL_ERROR;
}
if (intFlags & TKO_OPTION_READONLY) {
intFlags &= ~TKO_OPTION_READONLY;
readonly = TKO_OPTION_READONLY;
}
else {
readonly = 0;
}
/* return if no widget given, all class checks are done */
if(widget == NULL) {
return TCL_OK;
}
optionUid = Tk_GetUid(ch);
dbnameUid = Tk_GetUid(Tcl_GetString(dbname));
entryPtr = Tcl_CreateHashEntry(&widget->optionsTable, optionUid, &isNew);
if(isNew == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("option \"%s\" exists", ch));
return TCL_ERROR;
}
/* create option */
optionPtr = (WidgetOption *) ckalloc(sizeof(WidgetOption));
optionPtr->option = option;
Tcl_IncrRefCount(optionPtr->option);
optionPtr->dbname = dbname;
Tcl_IncrRefCount(optionPtr->dbname);
optionPtr->dbclass = NULL;
optionPtr->defvalue = NULL;
optionPtr->value = NULL;
optionPtr->flags = intFlags;
Tcl_SetHashValue(entryPtr, (char *)optionPtr);
/* synonym options can have init value */
if(dbclass == NULL) {
if(value) {
optionPtr->value = value;
Tcl_IncrRefCount(optionPtr->value);
}
/* normal option */
} else {
dbclassUid = Tk_GetUid(Tcl_GetString(dbclass));
optionPtr->dbclass = dbclass;
Tcl_IncrRefCount(optionPtr->dbclass);
if(defvalue) {
optionPtr->defvalue = defvalue;
} else {
optionPtr->defvalue = TkoObj.empty;
}
Tcl_IncrRefCount(optionPtr->defvalue);
/*
* If value is given use it.
*/
if(value) {
optionPtr->value = value;
} else {
/*
* Get value from option database
*/
if(optionPtr->value == NULL) {
valueUid = Tk_GetOption(widget->tkWin, dbnameUid, dbclassUid);
if(valueUid != NULL) {
optionPtr->value = Tcl_NewStringObj(valueUid, -1);
}
}
/*
* Check for a system-specific default value.
* Do not for -class because Tcl_SetClass was not called.
* When -class is not first option (after -screen) we get a crash!
*/
if(optionPtr->value == NULL && optionUid != TkoUid_class) {
optionPtr->value =
TkpGetSystemDefault(widget->tkWin, dbnameUid, dbclassUid);
}
/*
* Use default value.
*/
if(optionPtr->value == NULL) {
optionPtr->value = defvalue;
}
}
/*
* No given value defaults to empty string.
*/
if(optionPtr->value == NULL) {
optionPtr->value = TkoObj.empty;
}
Tcl_IncrRefCount(optionPtr->value);
/*
* Outside initmode the trace on the array variable needs to be disabled.
*/
if (initmode == 0) {
Tcl_UntraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL,
TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget);
traceadd = 1;
}
/*
*Set option array variable
*/
if (Tcl_ObjSetVar2(interp, widget->optionsArray, option,
optionPtr->value, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
goto error;
}
/*
* Do initialization with -option method.
*/
if (readonly || initmode == 0) {
myObjv[0] = widget->myCmd;
myObjv[1] = option;
if (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) {
goto error;
}
/*
* We set the value again because the -option method may have changed it.
*/
if (optionPtr->value) {
Tcl_DecrRefCount(optionPtr->value);
}
optionPtr->value = Tcl_ObjGetVar2(interp, widget->optionsArray, option, TCL_GLOBAL_ONLY); /*TODO flags? */
Tcl_IncrRefCount(optionPtr->value);
/* Now we are ready to set the readonly bit */
if (readonly) {
optionPtr->flags |= TKO_OPTION_READONLY;
}
}
}
if (traceadd) {
Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL,
TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget);
}
return TCL_OK;
error:
if (traceadd) {
/* There should be no error and thus we don't need to save the result. */
Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL,
TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget);
}
WidgetOptionDelEntry(entryPtr);
return TCL_ERROR;
}
/*
* WidgetOptionConfigure --
*
* Results:
*
* Side effects:
*/
static int
WidgetOptionConfigure(
Tcl_Interp * interp,
tkoWidget * widget,
int objc,
Tcl_Obj * const objv[])
{
int i;
Tcl_Obj *myObjv[2];
if(objc % 2) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing value"));
return TCL_ERROR;
}
Tcl_Preserve(widget);
for(i = 0; i < objc; i = i + 2) {
if(WidgetOptionSet(interp, widget, objv[i], objv[i + 1]) != TCL_OK) {
Tcl_Release(widget);
return TCL_ERROR;
}
}
myObjv[0] = widget->myCmd;
myObjv[1] = TkoObj._tko_configure;
if(Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_Release(widget);
return TCL_ERROR;
}
Tcl_Release(widget);
return TCL_OK;
}
/*
* WidgetOptionDel --
*
* Results:
*
* Side effects:
*/
static int
WidgetOptionDel(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option)
{
Tcl_HashEntry *entryPtr;
if(option == NULL) {
return TCL_ERROR;
}
/* delete single option */
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(option)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(option)));
return TCL_ERROR;
}
/* delete with no additional check on synonym option */
Tcl_UnsetVar2(interp, Tcl_GetString(widget->optionsArray),
Tcl_GetString(option), TCL_GLOBAL_ONLY);
WidgetOptionDelEntry(entryPtr);
return TCL_OK;
}
/*
* WidgetOptionGet --
*
* Results:
*
* Side effects:
*/
static int
WidgetOptionGet(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option)
{
Tcl_Obj *retPtr;
Tcl_HashEntry *entryPtr;
WidgetOption *optionPtr;
if(option == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("no option given"));
return TCL_ERROR;
}
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(option)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
/* hidden option, not visible in cget method */
if (optionPtr->flags&TKO_OPTION_HIDE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
/* synonym option */
if(optionPtr->dbclass == NULL) {
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(optionPtr->dbname)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown synonym option \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
if(optionPtr->dbclass == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("synonym option is synonym \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
}
retPtr = optionPtr->value;
Tcl_SetObjResult(interp, retPtr);
return TCL_OK;
}
/*
* WidgetOptionSet --
*
* Results:
*
* Side effects:
*/
static int
WidgetOptionSet(
Tcl_Interp * interp,
tkoWidget * widget,
Tcl_Obj * option,
Tcl_Obj * value)
{
Tcl_HashEntry *entryPtr;
WidgetOption *optionPtr;
if(option == NULL || value == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing option and/or value"));
return TCL_ERROR;
}
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(option)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(option)));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
/* hidden option, not visible in cget method */
if (optionPtr->flags&TKO_OPTION_HIDE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
/* synonym option */
if(optionPtr->dbclass == NULL) {
entryPtr =
Tcl_FindHashEntry(&widget->optionsTable,
Tk_GetUid(Tcl_GetString(optionPtr->dbname)));
if(entryPtr == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("unknown synonym option \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
optionPtr = Tcl_GetHashValue(entryPtr);
if(optionPtr->dbclass == NULL) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("synonym option is synonym \"%s\"",
Tcl_GetString(option)));
return TCL_ERROR;
}
if(Tcl_ObjSetVar2(interp, widget->optionsArray, optionPtr->option,
value, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
} else {
if(Tcl_ObjSetVar2(interp, widget->optionsArray, option, value,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* TkoWidgetOptionGet --
*
* Results:
*
* Side effects:
*/
Tcl_Obj *
TkoWidgetOptionGet(
Tcl_Interp * interp,
Tcl_Object object,
Tcl_Obj * option)
{
tkoWidget *widget = (tkoWidget *) Tcl_ObjectGetMetadata(object, &tkoWidgetMeta);
if(widget == NULL) {
return NULL;
}
return Tcl_ObjGetVar2(interp, widget->optionsArray, option,
TCL_GLOBAL_ONLY);
}
/*
* TkoWidgetOptionSet --
*
* Results:
*
* Side effects:
*/
int
TkoWidgetOptionSet(
Tcl_Interp * interp,
Tcl_ObjectContext context,
Tcl_Obj * option,
tkoWidgetOptionType type,
Tcl_ObjectMetadataType * meta,
size_t offset)
{
Tcl_Object object;
tkoWidget *widget;
Tcl_Obj *value;
char *address = NULL;
int intVal;
double dblVal;
Colormap colormap;
int *intPtr;
const char *str;
int length;
int pixels[4] = { 0, 0, 0, 0 };
int objc;
Tcl_Obj **objv;
Visual * visual;
XColor * color;
Tk_3DBorder border;
Tk_Anchor anchor;
Tk_Cursor cursor;
Tk_Window newWin;
Tk_Font newFont;
Tk_Justify justify;
if((object = Tcl_ObjectContextObject(context)) == NULL
|| (widget =
(tkoWidget *) Tcl_ObjectGetMetadata(object, &tkoWidgetMeta)) == NULL
|| (value =
Tcl_ObjGetVar2(interp, widget->optionsArray, option,
TCL_GLOBAL_ONLY)) == NULL || widget->tkWin == NULL) {
return TCL_ERROR;
}
if(meta) {
if((address = Tcl_ObjectGetMetadata(object, meta)) == NULL) {
return TCL_ERROR;
}
address += offset;
}
switch (type) {
case TKO_SET_CLASS: /* (Tcl_Obj **)address */
Tk_SetClass(widget->tkWin, Tcl_GetString(value));
if(address) {
if(*((Tcl_Obj **) address) != NULL)
Tcl_DecrRefCount(*((Tcl_Obj **) address));
*((Tcl_Obj **) address) = value;
Tcl_IncrRefCount(value);
}
return TCL_OK;
case TKO_SET_VISUAL: /* (Tcl_Obj **)address */
visual =
Tk_GetVisual(interp, widget->tkWin, Tcl_GetString(value), &intVal,
&colormap);
if(visual == NULL)
return TCL_ERROR;
Tk_SetWindowVisual(widget->tkWin, visual, intVal, colormap);
if(address) {
if(*((Tcl_Obj **) address) != NULL)
Tcl_DecrRefCount(*((Tcl_Obj **) address));
*((Tcl_Obj **) address) = value;
Tcl_IncrRefCount(value);
}
return TCL_OK;
case TKO_SET_COLORMAP: /* (Tcl_Obj **)address */
str = Tcl_GetStringFromObj(value, &length);
if(str && length) {
colormap = Tk_GetColormap(interp, widget->tkWin, str);
if(colormap == None)
return TCL_ERROR;
Tk_SetWindowColormap(widget->tkWin, colormap);
}
if(address) {
if(*((Tcl_Obj **) address) != NULL)
Tcl_DecrRefCount(*((Tcl_Obj **) address));
*((Tcl_Obj **) address) = value;
Tcl_IncrRefCount(value);
}
return TCL_OK;
case TKO_SET_USENULL: /* (Tcl_Obj **)address */
str = Tcl_GetStringFromObj(value, &length);
if(str && length) {
if(TkpUseWindow(interp, widget->tkWin, str) != TCL_OK) {
return TCL_ERROR;
}
}
if(address) {
if(*((Tcl_Obj **) address) != NULL)
Tcl_DecrRefCount(*((Tcl_Obj **) address));
if(length) {
*((Tcl_Obj **) address) = value;
Tcl_IncrRefCount(value);
} else {
*((Tcl_Obj **) address) = NULL;
}
}
return TCL_OK;
case TKO_SET_CONTAINER: /* (int *)address */
if(Tcl_GetBooleanFromObj(interp, value, &intVal) != TCL_OK)
return TCL_ERROR;
if(intVal) {
TkpMakeContainer(widget->tkWin);
Tcl_ObjSetVar2(interp, widget->optionsArray, option, TkoObj._1,
TCL_GLOBAL_ONLY);
} else {
Tcl_ObjSetVar2(interp, widget->optionsArray, option, TkoObj._0,
TCL_GLOBAL_ONLY);
}
if(address) {
*(int *)address = intVal;
}
return TCL_OK;
case TKO_SET_TCLOBJ: /* (Tcl_Obj **)address */
if(address) {
if(*((Tcl_Obj **) address) != NULL)
Tcl_DecrRefCount(*((Tcl_Obj **) address));
*((Tcl_Obj **) address) = value;
Tcl_IncrRefCount(value);
}
return TCL_OK;
case TKO_SET_XCOLOR: /* (Xcolor **)address */
color = Tk_AllocColorFromObj(interp, widget->tkWin, value);
if(color == NULL)
return TCL_ERROR;
if(address) {
if(*((XColor **) address) != NULL) {
Tk_FreeColor(*((XColor **) address));
}
*((XColor **) address) = color;
} else {
Tk_FreeColor(color);
}
return TCL_OK;
case TKO_SET_3DBORDER: /* (Tk_3DBorder *)address */
border = Tk_Alloc3DBorderFromObj(interp, widget->tkWin, value);
if(border == NULL)
return TCL_ERROR;
if(address) {
if(*(Tk_3DBorder *) address != NULL) {
Tk_Free3DBorder(*(Tk_3DBorder *) address);
}
*(Tk_3DBorder *) address = border;
} else {
Tk_Free3DBorder(border);
}
return TCL_OK;
case TKO_SET_PIXEL: /* (int *)address */
if(Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(int *)address = intVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_PIXELNONEGATIV: /* (int *)address */
if(Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(intVal >= SHRT_MAX) {
Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value),
"\": ", "too big to represent", (char *)NULL);
return TCL_ERROR;
}
if(intVal < 0) {
Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value),
"\": ", "can't be negative", (char *)NULL);
return TCL_ERROR;
}
if(address) {
*(int *)address = intVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_PIXELPOSITIV: /* (int *)address */
if(Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(intVal >= SHRT_MAX) {
Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value),
"\": ", "too big to represent", (char *)NULL);
return TCL_ERROR;
}
if(intVal <= 0) {
Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value),
"\": ", "must be positive", (char *)NULL);
return TCL_ERROR;
}
if(address) {
*(int *)address = intVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_DOUBLE: /* (double *)address */
if(Tcl_GetDoubleFromObj(interp, value, &dblVal) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(double *)address = dblVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewDoubleObj(dblVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_BOOLEAN: /* (int *)address */
if(Tcl_GetBooleanFromObj(interp, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(intVal) {
Tcl_ObjSetVar2(interp, widget->optionsArray, option, TkoObj._1,
TCL_GLOBAL_ONLY);
} else {
Tcl_ObjSetVar2(interp, widget->optionsArray, option, TkoObj._0,
TCL_GLOBAL_ONLY);
}
if(address) {
*(int *)address = intVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_CURSOR: /* (Tk_Cursor *)address */
cursor = None;
if(Tcl_GetString(value)[0] != '\0') {
cursor = Tk_AllocCursorFromObj(interp, widget->tkWin, value);
if(cursor == None) {
return TCL_ERROR;
}
Tk_DefineCursor(widget->tkWin, cursor);
}
if(address) {
if(*(Tk_Cursor *) address != None) {
Tk_FreeCursor(Tk_Display(widget->tkWin),
*(Tk_Cursor *) address);
}
*(Tk_Cursor *) address = cursor;
} else {
if(cursor != None) {
Tk_FreeCursor(Tk_Display(widget->tkWin), cursor); /*TODO necessary? */
}
}
return TCL_OK;
case TKO_SET_INT: /* (int *)address */
if(Tcl_GetIntFromObj(interp, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(int *)address = intVal;
}
Tcl_ObjSetVar2(interp, widget->optionsArray, option,
Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY);
return TCL_OK;
case TKO_SET_RELIEF: /* (int *)address */
if(Tk_GetReliefFromObj(interp, value, &intVal) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(int *)address = intVal;
}
return TCL_OK;
case TKO_SET_ANCHOR: /* (Tk_Anchor *)address */
if(Tk_GetAnchorFromObj(interp, value, &anchor) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(Tk_Anchor *) address = anchor;
}
return TCL_OK;
case TKO_SET_WINDOW: /* (Tk_Window *)address */
if(value == NULL || Tcl_GetCharLength(value) == 0) {
newWin = None;
} else {
if(TkGetWindowFromObj(interp, widget->tkWin, value,
&newWin) != TCL_OK) {
return TCL_ERROR;
}
}
if(address) {
*(Tk_Window *) address = newWin;
}
return TCL_OK;
case TKO_SET_FONT: /* (Tk_Font *)address */
newFont = Tk_AllocFontFromObj(interp, widget->tkWin, value);
if(newFont == NULL) {
return TCL_ERROR;
}
if(address) {
if(*(Tk_Font *) address != NULL) {
Tk_FreeFont(*(Tk_Font *) address);
}
*(Tk_Font *) address = newFont;
} else {
Tk_FreeFont(newFont);
}
return TCL_OK;
case TKO_SET_STRING: /* (char **)address */
if(address) {
str = Tcl_GetStringFromObj(value, &length);
if(*(char **)address != NULL) {
ckfree(*(char **)address);
}
*(char **)address = ckalloc(length + 1);
memcpy(*(char **)address, str, length + 1);
}
return TCL_OK;
case TKO_SET_STRINGNULL: /* (char **)address */
if(address) {
str = Tcl_GetStringFromObj(value, &length);
if(*(char **)address != NULL) {
ckfree(*(char **)address);
}
if(length == 0) {
*(char **)address = NULL;
} else {
*(char **)address = ckalloc(length + 1);
memcpy(*(char **)address, str, length + 1);
}
}
return TCL_OK;
case TKO_SET_SCROLLREGION: /* (int *[4])address */
if(Tcl_ListObjGetElements(interp, value, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if(objc == 4) {
if(Tk_GetPixelsFromObj(interp, widget->tkWin, objv[0],
&pixels[0]) != TCL_OK
|| Tk_GetPixelsFromObj(interp, widget->tkWin, objv[1],
&pixels[1]) != TCL_OK
|| Tk_GetPixelsFromObj(interp, widget->tkWin, objv[2],
&pixels[2]) != TCL_OK
|| Tk_GetPixelsFromObj(interp, widget->tkWin, objv[3],
&pixels[3]) != TCL_OK) {
return TCL_ERROR;
}
} else if(objc != 0) {
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("found %d instead of 4 values", objc));
return TCL_ERROR;
}
if(address) {
intPtr = (int *)address;
intPtr[0] = pixels[0];
intPtr[1] = pixels[1];
intPtr[2] = pixels[2];
intPtr[3] = pixels[3];
}
return TCL_OK;
case TKO_SET_JUSTIFY: /* (Tk_Justify *)address */
if(Tk_GetJustify(interp, Tk_GetUid(Tcl_GetString(value)),
&justify) != TCL_OK) {
return TCL_ERROR;
}
if(address) {
*(Tk_Justify *) address = justify;
}
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown type \"%d\"", type));
return TCL_ERROR;
}
/*
* WidgetOptionTrace --
*
* Write trace on option array variable
*
* Results:
*
* Side effects:
*/
static char *
WidgetOptionTrace(
ClientData clientData,
Tcl_Interp * interp,
const char *name1,
const char *name2,
int flags)
{
tkoWidget *widget = (tkoWidget *) clientData;
Tcl_HashEntry *entryPtr;
Tcl_Obj *valuePtr;
// const char *result;
WidgetOption *optionPtr;
Tcl_Obj *myObjv[2];
Tcl_Obj *myRet;
/* get new value */
entryPtr = Tcl_FindHashEntry(&widget->optionsTable, Tk_GetUid(name2));
if(entryPtr == NULL) {
myRet = Tcl_ObjPrintf("option \"%s\" not found", name2);
Tcl_IncrRefCount(myRet);
return (char *)myRet;
}
optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr);
if(optionPtr->flags & TKO_OPTION_READONLY) {
myRet = Tcl_ObjPrintf("option \"%s\" is readonly", name2);
Tcl_IncrRefCount(myRet);
return (char *)myRet;
}
myObjv[0] = widget->myCmd;
myObjv[1] = optionPtr->option;
if(Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) {
myRet = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(myRet);
/* reset to old value TODO checks? */
if(optionPtr->value != NULL) {
Tcl_ObjSetVar2(interp, widget->optionsArray, optionPtr->option,
optionPtr->value, TCL_GLOBAL_ONLY);
Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL);
}
return (char *)myRet;
}
if(optionPtr->value != NULL) {
Tcl_DecrRefCount(optionPtr->value);
}
valuePtr = Tcl_ObjGetVar2(interp, widget->optionsArray, optionPtr->option, TCL_GLOBAL_ONLY); /*TODO flags? */
optionPtr->value = valuePtr;
Tcl_IncrRefCount(optionPtr->value);
return NULL;
}
/*
* WidgetOptionDelEntry --
*
* Results:
*
* Side effects:
*/
static void
WidgetOptionDelEntry(
Tcl_HashEntry * entry)
{
WidgetOption *optionPtr = Tcl_GetHashValue(entry);
if(optionPtr->option)
Tcl_DecrRefCount(optionPtr->option);
if(optionPtr->dbname)
Tcl_DecrRefCount(optionPtr->dbname);
if(optionPtr->dbclass)
Tcl_DecrRefCount(optionPtr->dbclass);
if(optionPtr->defvalue)
Tcl_DecrRefCount(optionPtr->defvalue);
if(optionPtr->value)
Tcl_DecrRefCount(optionPtr->value);
ckfree(optionPtr);
Tcl_DeleteHashEntry(entry);
}
/*
* WidgetMethod_tko_configure --
* Virtual method called after configuring options.
* Should be implemented in derived classes.
*
* Results:
*
* Side effects:
*/
static int
WidgetMethod_tko_configure(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{ /* virtual method */
return TCL_OK;
}
/*
* WidgetMetaDelete --
* Delete widget meta data when all preserve calls done.
*
* Results:
*
* Side effects:
*/
static void
WidgetMetaDelete(
ClientData clientData)
{
Tcl_EventuallyFree(clientData, (Tcl_FreeProc *)WidgetMetaDestroy);
}
/*
* WidgetMethod_ --
* Call standard option set method.
*
* Results:
*
* Side effects:
*/
static int
WidgetMethod_(
ClientData clientData,
Tcl_Interp * interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj * const objv[])
{ /* common option set method */
tkoWidgetOptionDefine *define = (tkoWidgetOptionDefine *)clientData;
return TkoWidgetOptionSet(interp, context, define->optionPtr,
define->type, define->meta, define->offset);
}
/* vim: set ts=4 sw=4 sts=4 ff=unix et : */
Home
Timeline
Branches
Tags
Forum
Tickets
Download
Wiki