/* * 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 : */