/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * Procedures in this file support the new syntax for [incr Tcl] * class definitions: * * itcl_class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ?...? * protected ?...? * private ?...? * } * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * overhauled version author: Arnulf Wiedemann * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" static const char initWidgetScript[] = "namespace eval ::itcl {\n" " proc _find_widget_init {} {\n" " global env tcl_library\n" " variable library\n" " variable patchLevel\n" " rename _find_widget_init {}\n" " if {[info exists library]} {\n" " lappend dirs $library\n" " } else {\n" " set dirs {}\n" " if {[info exists env(ITCL_LIBRARY)]} {\n" " lappend dirs $env(ITCL_LIBRARY)\n" " }\n" " lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" " set bindir [file dirname [info nameofexecutable]]\n" " lappend dirs [file join . library]\n" " lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" " lappend dirs [file join $bindir .. library]\n" " lappend dirs [file join $bindir .. .. library]\n" " lappend dirs [file join $bindir .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" " # On MacOSX, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"] &&" " [string equal $::tcl_platform(os) \"Darwin\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " # On *nix, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs $d\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " }\n" " foreach i $dirs {\n" " set library $i\n" " set itclfile [file join $i itclWidget.tcl]\n" " if {![catch {uplevel #0 [list source $itclfile]} emsg]} {\n" " return\n" " }\n" " }\n" " set msg \"Can't find a usable itclWidget.tcl in the following directories:\n\"\n" " append msg \" $dirs\n\"\n" " append msg \"Last error:\n\"\n" " append msg \" $emsg\n\"\n" " append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" " append msg \"If you know where the Itcl library directory was installed,\n\"\n" " append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" " append msg \"to the library directory.\n\"\n" " error $msg\n" " }\n" " _find_widget_init\n" "}"; /* * Info needed for public/protected/private commands: */ typedef struct ProtectionCmdInfo { int pLevel; /* protection level */ ItclObjectInfo *infoPtr; /* info regarding all known objects */ } ProtectionCmdInfo; /* * FORWARD DECLARATIONS */ static Tcl_CmdDeleteProc ItclFreeParserCommandData; static void ItclDelObjectInfo(char* cdata); static int ItclInitClassCommon(Tcl_Interp *interp, ItclClass *iclsPtr, ItclVariable *ivPtr, const char *initStr); static Tcl_ObjCmdProc Itcl_ClassTypeVariableCmd; static Tcl_ObjCmdProc Itcl_ClassTypeMethodCmd; static Tcl_ObjCmdProc Itcl_ClassFilterCmd; static Tcl_ObjCmdProc Itcl_ClassMixinCmd; static Tcl_ObjCmdProc Itcl_WidgetCmd; static Tcl_ObjCmdProc Itcl_WidgetAdaptorCmd; static Tcl_ObjCmdProc Itcl_ClassComponentCmd; static Tcl_ObjCmdProc Itcl_ClassTypeComponentCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateMethodCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateOptionCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateTypeMethodCmd; static Tcl_ObjCmdProc Itcl_ClassForwardCmd; static Tcl_ObjCmdProc Itcl_ClassMethodVariableCmd; static Tcl_ObjCmdProc Itcl_ClassTypeConstructorCmd; static Tcl_ObjCmdProc ItclGenericClassCmd; static const struct { const char *name; Tcl_ObjCmdProc *objProc; } parseCmds[] = { {"common", Itcl_ClassCommonCmd}, {"component", Itcl_ClassComponentCmd}, {"constructor", Itcl_ClassConstructorCmd}, {"destructor", Itcl_ClassDestructorCmd}, {"filter", Itcl_ClassFilterCmd}, {"forward", Itcl_ClassForwardCmd}, {"handleClass", Itcl_HandleClass}, {"hulltype", Itcl_ClassHullTypeCmd}, {"inherit", Itcl_ClassInheritCmd}, {"method", Itcl_ClassMethodCmd}, {"methodvariable", Itcl_ClassMethodVariableCmd}, {"mixin", Itcl_ClassMixinCmd}, {"option", Itcl_ClassOptionCmd}, {"proc", Itcl_ClassProcCmd}, {"typecomponent", Itcl_ClassTypeComponentCmd }, {"typeconstructor", Itcl_ClassTypeConstructorCmd}, {"typemethod", Itcl_ClassTypeMethodCmd}, {"typevariable", Itcl_ClassTypeVariableCmd}, {"variable", Itcl_ClassVariableCmd}, {"widgetclass", Itcl_ClassWidgetClassCmd}, {NULL, NULL} }; static const struct { const char *name; Tcl_ObjCmdProc *objProc; int protection; } protectionCmds[] = { {"private", Itcl_ClassProtectionCmd, ITCL_PRIVATE}, {"protected", Itcl_ClassProtectionCmd, ITCL_PROTECTED}, {"public", Itcl_ClassProtectionCmd, ITCL_PUBLIC}, {NULL, NULL, 0} }; /* * ------------------------------------------------------------------------ * Itcl_ParseInit() * * Invoked by Itcl_Init() whenever a new interpreter is created to add * [incr Tcl] facilities. Adds the commands needed to parse class * definitions. * ------------------------------------------------------------------------ */ int Itcl_ParseInit( Tcl_Interp *interp, /* interpreter to be updated */ ItclObjectInfo *infoPtr) /* info regarding all known objects and classes */ { Tcl_Namespace *parserNs; ProtectionCmdInfo *pInfoPtr; Tcl_DString buffer; int i; /* * Create the "itcl::parser" namespace used to parse class * definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", infoPtr, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (cannot initialize itcl parser)", NULL); return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add commands for parsing class definitions. */ Tcl_DStringInit(&buffer); for (i=0 ; parseCmds[i].name ; i++) { Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); Tcl_DStringAppend(&buffer, parseCmds[i].name, TCL_INDEX_NONE); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), parseCmds[i].objProc, infoPtr, NULL); Tcl_DStringFree(&buffer); } for (i=0 ; protectionCmds[i].name ; i++) { Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); Tcl_DStringAppend(&buffer, protectionCmds[i].name, TCL_INDEX_NONE); pInfoPtr = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfoPtr->pLevel = protectionCmds[i].protection; pInfoPtr->infoPtr = infoPtr; Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), protectionCmds[i].objProc, pInfoPtr, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); Tcl_DStringFree(&buffer); } /* * Set the runtime variable resolver for the parser namespace, * to control access to "common" data members while parsing * the class definition. */ if (infoPtr->useOldResolvers) { ItclSetParserResolver(parserNs); } /* * Install the "class" command for defining new classes. */ Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd, NULL, NULL); Itcl_EventuallyFree(infoPtr, (Tcl_FreeProc *) ItclDelObjectInfo); /* * Create the "itcl::find" command for high-level queries. */ if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::find", "classes", "?pattern?", Itcl_FindClassesCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::find", "objects", "?-class className? ?-isa className? ?pattern?", Itcl_FindObjectsCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Create the "itcl::delete" command to delete objects * and classes. */ if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "class", "name ?name...?", Itcl_DelClassCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "object", "name ?name...?", Itcl_DelObjectCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "ensemble", "name ?name...?", Itcl_EnsembleDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Create the "itcl::is" command to test object * and classes existence. */ if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::is", "class", "name", Itcl_IsClassCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::is", "object", "?-class classname? name", Itcl_IsObjectCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add "code" and "scope" commands for handling scoped values. */ Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd, NULL, NULL); /* * Add the "filter" commands (add/delete) */ if (Itcl_CreateEnsemble(interp, "::itcl::filter") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add the "forward" commands (add/delete) */ if (Itcl_CreateEnsemble(interp, "::itcl::forward") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "add", "objectOrClass srcCommand targetCommand ? options ... ?", Itcl_ForwardAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "delete", "objectOrClass targetCommand ? ... ?", Itcl_ForwardDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add the "mixin" (add/delete) commands. */ if (Itcl_CreateEnsemble(interp, "::itcl::mixin") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "add", "objectOrClass class ? class ... ?", Itcl_MixinAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "delete", "objectOrClass class ? class ... ?", Itcl_MixinDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add commands for handling import stubs at the Tcl level. */ if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "create", "name", Itcl_StubCreateCmd, NULL, NULL) != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "exists", "name", Itcl_StubExistsCmd, NULL, NULL) != TCL_OK) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addobjectoption", Itcl_AddObjectOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption", Itcl_AddDelegatedOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod", Itcl_AddDelegatedFunctionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass", ItclGenericClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); /* * Add the "delegate" (method/option) commands. */ if (Itcl_CreateEnsemble(interp, "::itcl::parser::delegate") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "method", "name to targetName as scipt using script", Itcl_ClassDelegateMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "typemethod", "name to targetName as scipt using script", Itcl_ClassDelegateTypeMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "option", "option to targetOption as script", Itcl_ClassDelegateOptionCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::class" command to * specify a class definition. Handles the following syntax: * * itcl::class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ... * protected ... * private ... * } * * ------------------------------------------------------------------------ */ static int ItclGenericClassCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclComponent *icPtr; const char *typeStr; int result; ItclShowArgs(1, "ItclGenericClassCmd", objc-1, objv); if (objc != 4) { Tcl_AppendResult(interp, "usage: genericclass ", "", NULL); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)clientData; typeStr = Tcl_GetString(objv[1]); hPtr = Tcl_FindHashEntry(&infoPtr->classTypes, (char *)objv[1]); if (hPtr == NULL) { Tcl_AppendResult(interp, "genericclass bad classtype \"", typeStr, "\"", NULL); return TCL_ERROR; } result = ItclClassBaseCmd(clientData, interp, PTR2INT(Tcl_GetHashValue(hPtr)), objc - 1, objv + 1, &iclsPtr); if (result != TCL_OK) { return result; } if (PTR2INT(Tcl_GetHashValue(hPtr)) == ITCL_WIDGETADAPTOR) { /* create the itcl_hull variable */ namePtr = Tcl_NewStringObj("itcl_hull", TCL_INDEX_NONE); if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON, &icPtr) != TCL_OK) { return TCL_ERROR; } iclsPtr->numVariables++; } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::class" command to * specify a class definition. Handles the following syntax: * * itcl::class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ... * protected ... * private ... * } * * ------------------------------------------------------------------------ */ int Itcl_ClassCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, NULL); } /* * ------------------------------------------------------------------------ * ItclClassBaseCmd() * * ------------------------------------------------------------------------ */ static Tcl_MethodCallProc ObjCallProc; static Tcl_MethodCallProc ArgCallProc; static Tcl_CloneProc CloneProc; static const Tcl_MethodType itclObjMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl objv method", ObjCallProc, Itcl_ReleaseData, CloneProc }; static const Tcl_MethodType itclArgMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl argv method", ArgCallProc, Itcl_ReleaseData, CloneProc }; static int CloneProc( TCL_UNUSED(Tcl_Interp *), void *original, void **copyPtr) { Itcl_PreserveData((ItclMemberFunc *)original); *copyPtr = original; return TCL_OK; } static int CallAfterCallMethod( void *data[], Tcl_Interp *interp, int result) { void *clientData = data[0]; Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; return ItclAfterCallMethod(clientData, interp, context, NULL, result); } static int ObjCallProc( void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; if (TCL_ERROR == ItclCheckCallMethod(clientData, interp, context, NULL, NULL)) { return TCL_ERROR; } Tcl_NRAddCallback(interp, CallAfterCallMethod, clientData, context, NULL, NULL); if ((imPtr->flags & ITCL_COMMON) == 0) { return Itcl_ExecMethod(clientData, interp, objc-1, objv+1); } else { return Itcl_ExecProc(clientData, interp, objc-1, objv+1); } } static int ArgCallProc( TCL_UNUSED(void *), TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(Tcl_ObjectContext), TCL_UNUSED(int), TCL_UNUSED(Tcl_Obj *const *)) { return TCL_ERROR; } int ItclClassBaseCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int flags, /* flags: ITCL_CLASS, ITCL_TYPE, * ITCL_WIDGET or ITCL_WIDGETADAPTOR */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclClass **iclsPtrPtr) /* for returning iclsPtr */ { Tcl_Obj *argumentPtr; Tcl_Obj *bodyPtr; FOREACH_HASH_DECLS; Tcl_HashEntry *hPtr2; Tcl_Namespace *parserNs, *ooNs; Tcl_CallFrame frame; ItclClass *iclsPtr; ItclVariable *ivPtr; ItclObjectInfo* infoPtr; char *className; int isNewEntry; int result; int noCleanup; ItclMemberFunc *imPtr; infoPtr = (ItclObjectInfo*)clientData; if (iclsPtrPtr != NULL) { *iclsPtrPtr = NULL; } if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); return TCL_ERROR; } ItclShowArgs(1, "ItclClassBaseCmd", objc, objv); className = Tcl_GetString(objv[1]); noCleanup = 0; /* * Find the namespace to use as a parser for the class definition. * If for some reason it is destroyed, bail out here. */ parserNs = Tcl_FindNamespace(interp, "::itcl::parser", NULL, TCL_LEAVE_ERR_MSG); if (parserNs == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while parsing class definition for \"%s\")", className)); return TCL_ERROR; } /* * Try to create the specified class and its namespace. */ /* need the workaround with infoPtr->currClassFlags to keep the stubs * call interface compatible! */ infoPtr->currClassFlags = flags; if (Itcl_CreateClass(interp, className, infoPtr, &iclsPtr) != TCL_OK) { infoPtr->currClassFlags = 0; return TCL_ERROR; } infoPtr->currClassFlags = 0; iclsPtr->flags = flags; /* * Import the built-in commands from the itcl::builtin namespace. * Do this before parsing the class definition, so methods/procs * can override the built-in commands. */ result = Tcl_Import(interp, iclsPtr->nsPtr, "::itcl::builtin::*", /* allowOverwrite */ 1); ooNs = Tcl_GetObjectNamespace(iclsPtr->oPtr); if ( result == TCL_OK && ooNs != iclsPtr->nsPtr) { result = Tcl_Import(interp, ooNs, "::itcl::builtin::*", 1); } if (result != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while installing built-in commands for class \"%s\")", className)); goto errorReturn; } /* * Push this class onto the class definition stack so that it * becomes the current context for all commands in the parser. * Activate the parser and evaluate the class definition. */ Itcl_PushStack(iclsPtr, &infoPtr->clsStack); result = Itcl_PushCallFrame(interp, &frame, parserNs, /* isProcCallFrame */ 0); Itcl_SetCallFrameResolver(interp, iclsPtr->resolvePtr); if (result == TCL_OK) { result = Tcl_EvalObjEx(interp, objv[2], 0); Itcl_PopCallFrame(interp); } Itcl_PopStack(&infoPtr->clsStack); noCleanup = 0; if (result != TCL_OK) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); Tcl_Obj *key = Tcl_NewStringObj("-errorline", TCL_INDEX_NONE); Tcl_Obj *stackTrace = NULL; Tcl_IncrRefCount(key); Tcl_DictObjGet(NULL, options, key, &stackTrace); Tcl_DecrRefCount(key); if (stackTrace == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n error while parsing class \"%s\" body %s", className, Tcl_GetString(objv[2]))); noCleanup = 1; } else { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (class \"%s\" body line %s)", className, Tcl_GetString(stackTrace))); } Tcl_DecrRefCount(options); result = TCL_ERROR; goto errorReturn; } if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) { /* No [inherit]. Use default inheritance root. */ Tcl_Obj *cmdPtr = Tcl_NewListObj(4, NULL); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("::oo::define", TCL_INDEX_NONE)); Tcl_ListObjAppendElement(NULL, cmdPtr, iclsPtr->fullNamePtr); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("superclass", TCL_INDEX_NONE)); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("::itcl::Root", TCL_INDEX_NONE)); Tcl_IncrRefCount(cmdPtr); result = Tcl_EvalObjEx(interp, cmdPtr, 0); Tcl_DecrRefCount(cmdPtr); if (result == TCL_ERROR) { goto errorReturn; } } /* * At this point, parsing of the class definition has succeeded. * Add built-in methods such as "configure" and "cget"--as long * as they don't conflict with those defined in the class. */ if (Itcl_InstallBiMethods(interp, iclsPtr) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } /* * Build the name resolution tables for all data members. */ Itcl_BuildVirtualTables(iclsPtr); /* make the methods and procs known to TclOO */ FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { void *pmPtr; argumentPtr = imPtr->codePtr->argumentPtr; bodyPtr = imPtr->codePtr->bodyPtr; if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) { /* Implementation of this member is coded in C expecting Tcl_Obj */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); Itcl_PreserveData(imPtr); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); Itcl_PreserveData(imPtr); } } else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) { /* Implementation of this member is coded in C expecting (char *) */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclArgMethodType, imPtr); Itcl_PreserveData(imPtr); } else { if (imPtr->codePtr->flags & ITCL_BUILTIN) { int isDone; isDone = 0; if (imPtr->builtinArgumentPtr == NULL) { /* FIXME next lines are possibly a MEMORY leak not really sure!! */ argumentPtr = Tcl_NewStringObj("args", TCL_INDEX_NONE); imPtr->builtinArgumentPtr = argumentPtr; Tcl_IncrRefCount(imPtr->builtinArgumentPtr); } else { argumentPtr = imPtr->builtinArgumentPtr; } bodyPtr = Tcl_NewStringObj("return [", TCL_INDEX_NONE); if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-cget") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::cget", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-configure") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::configure", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-isa") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::isa", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-createhull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::createhull", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-keepcomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepcomponentoption", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-ignorecomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignorercomponentoption", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-renamecomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renamecomponentoption", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-keepoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepoptioncomponent", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-ignoreoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignoreoptioncomponent", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-renameoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renameoptioncomponent", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-setupcomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setupcomponent", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-initoptions") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::initoptions", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-getinstancevar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::getinstancevar", TCL_INDEX_NONE); isDone = 1; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR| ITCL_WIDGET|ITCL_ECLASS)) { /* now the builtin stuff for snit functionality */ if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mytypemethod") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypemethod", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mymethod") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mymethod", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-myvar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myvar", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mytypevar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypevar", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-itcl_hull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::itcl_hull", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-callinstance") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::callinstance", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-myproc") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myproc", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-installhull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installhull", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-installcomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installcomponent", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-classunknown") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::classunknown", TCL_INDEX_NONE); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-destroy") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::destroy", TCL_INDEX_NONE); isDone = 1; } } if (strncmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-setget", 20) == 0) { char *cp = Tcl_GetString(imPtr->codePtr->bodyPtr)+20; Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setget ", TCL_INDEX_NONE); Tcl_AppendToObj(bodyPtr, cp, TCL_INDEX_NONE); Tcl_AppendToObj(bodyPtr, " ", 1); isDone = 1; } if (!isDone) { Tcl_AppendToObj(bodyPtr, Tcl_GetString(imPtr->codePtr->bodyPtr), TCL_INDEX_NONE); } Tcl_AppendToObj(bodyPtr, " {*}$args]", TCL_INDEX_NONE); } imPtr->tmPtr = Itcl_NewProcClassMethod(interp, iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); hPtr2 = Tcl_CreateHashEntry(&iclsPtr->infoPtr->procMethods, (char *)imPtr->tmPtr, &isNewEntry); if (isNewEntry) { Tcl_SetHashValue(hPtr2, imPtr); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (argumentPtr == NULL) { argumentPtr = iclsPtr->infoPtr->typeDestructorArgumentPtr; imPtr->codePtr->argumentPtr = argumentPtr; Tcl_IncrRefCount(argumentPtr); } /* * We're overwriting the tmPtr field, so yank out the * entry in the procMethods map based on the old one. */ if (isNewEntry) { Tcl_DeleteHashEntry(hPtr2); } imPtr->tmPtr = Itcl_NewProcMethod(interp, iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); } } if ((imPtr->flags & ITCL_COMMON) == 0) { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), Itcl_ExecMethod, imPtr, Itcl_ReleaseData); Itcl_PreserveData(imPtr); } else { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), Itcl_ExecProc, imPtr, Itcl_ReleaseData); Itcl_PreserveData(imPtr); } } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { /* initialize the typecomponents and typevariables */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((ivPtr->flags & ITCL_COMMON) && (ivPtr->init != NULL)) { if (Tcl_SetVar2(interp, Tcl_GetString(ivPtr->namePtr), NULL, Tcl_GetString(ivPtr->init), TCL_NAMESPACE_ONLY) == NULL) { Itcl_PopCallFrame(interp); result = TCL_ERROR; goto errorReturn; } } } Itcl_PopCallFrame(interp); } if (iclsPtr->typeConstructorPtr != NULL) { /* call the typeconstructor body */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } result = Tcl_EvalObjEx(interp, iclsPtr->typeConstructorPtr, TCL_EVAL_DIRECT); Itcl_PopCallFrame(interp); if (result != TCL_OK) { goto errorReturn; } } result = TCL_OK; if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { if (ItclCheckForInitializedComponents(interp, iclsPtr, NULL) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } } if (result == TCL_OK) { Tcl_ResetResult(interp); } if (iclsPtrPtr != NULL) { *iclsPtrPtr = iclsPtr; } ItclAddClassesDictInfo(interp, iclsPtr); return result; errorReturn: if (!noCleanup) { Tcl_DeleteNamespace(iclsPtr->nsPtr); } return result; } /* * ------------------------------------------------------------------------ * ItclCheckForInitializedComponents() * * check if all components for delegation exist and are initialized * ------------------------------------------------------------------------ */ int ItclCheckForInitializedComponents( Tcl_Interp *interp, ItclClass *iclsPtr, ItclObject *ioPtr) { FOREACH_HASH_DECLS; Tcl_CallFrame frame; Tcl_DString buffer; ItclDelegatedFunction *idmPtr; int result; int doCheck; result = TCL_OK; /* check if the typecomponents are initialized */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { return TCL_ERROR; } idmPtr = NULL; FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { const char *val; /* check here for delegated typemethods only * rest is done in ItclCreateObject */ doCheck = 1; if (ioPtr == NULL) { if (!(idmPtr->flags & ITCL_TYPE_METHOD)) { doCheck = 0; ioPtr = iclsPtr->infoPtr->currIoPtr; } } if (doCheck) { if (idmPtr->icPtr != NULL) { if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { Tcl_Obj *objPtr; objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( idmPtr->icPtr->ivPtr->iclsPtr->oPtr))->fullName, TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, "::", TCL_INDEX_NONE); Tcl_AppendToObj(objPtr, Tcl_GetString( idmPtr->icPtr->ivPtr->namePtr), TCL_INDEX_NONE); val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); Tcl_DecrRefCount(objPtr); } else { Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, Tcl_GetString(ioPtr->varNsNamePtr), TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), TCL_INDEX_NONE); val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); } if ((ioPtr != NULL) && ((val != NULL) && (strlen(val) == 0))) { val = ItclGetInstanceVar( ioPtr->iclsPtr->interp, "itcl_hull", NULL, ioPtr, iclsPtr); } if ((val == NULL) || (strlen(val) == 0)) { if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { if (strcmp (Tcl_GetString(idmPtr->icPtr->namePtr), "itcl_hull") == 0) { /* maybe that will be initialized in constructor * later on */ continue; } } result = TCL_ERROR; break; } } } } Itcl_PopCallFrame(interp); if (result == TCL_ERROR) { const char *startStr; const char *sepStr; const char *objectStr; startStr = ""; sepStr = ""; objectStr = ""; if (ioPtr != NULL) { sepStr = " "; objectStr = Tcl_GetString(ioPtr->origNamePtr); } if (idmPtr->flags & ITCL_TYPE_METHOD) { startStr = "type"; } /* FIXME there somtimes is a message for widgetadaptor: * can't read "itcl_hull": no such variable * have to check why */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), sepStr, objectStr, " delegates ", startStr, "method \"", Tcl_GetString(idmPtr->namePtr), "\" to undefined ", startStr, "component \"", Tcl_GetString(idmPtr->icPtr->ivPtr->namePtr), "\"", NULL); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassInheritCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "inherit" command is invoked to define one or more base classes. * Handles the following syntax: * * inherit ?...? * * ------------------------------------------------------------------------ */ int Itcl_ClassInheritCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); int result; Tcl_Size i; int newEntry; int haveClasses; const char *token; Itcl_ListElem *elem; Itcl_ListElem *elem2; ItclClass *cdPtr; ItclClass *baseClsPtr; ItclClass *badCdPtr; ItclHierIter hier; Itcl_Stack stack; Tcl_CallFrame frame; Tcl_DString buffer; ItclShowArgs(2, "Itcl_InheritCmd", objc, objv); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::inherit called from", " not within a class", NULL); return TCL_ERROR; } /* * An "inherit" statement can only be included once in a * class definition. */ elem = Itcl_FirstListElem(&iclsPtr->bases); if (elem != NULL) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", TCL_INDEX_NONE); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), Tcl_GetString(cdPtr->namePtr), " ", NULL); elem = Itcl_NextListElem(elem); } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\" already defined for class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * Validate each base class and add it to the "bases" list. */ result = Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr->parentPtr, /* isProcCallFrame */ 0); if (result != TCL_OK) { return TCL_ERROR; } for (objc--,objv++; objc > 0; objc--,objv++) { /* * Make sure that the base class name is known in the * parent namespace (currently active). If not, try * to autoload its definition. */ token = Tcl_GetString(*objv); baseClsPtr = Itcl_FindClass(interp, token, /* autoload */ 1); if (!baseClsPtr) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_Size errlen; char *errmsg; Tcl_IncrRefCount(resultPtr); errmsg = Tcl_GetStringFromObj(resultPtr, &errlen); Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot inherit from \"", token, "\"", NULL); if (errlen > 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (", errmsg, ")", NULL); } Tcl_DecrRefCount(resultPtr); goto inheritError; } /* * Make sure that the base class is not the same as the * class that is being built. */ if (baseClsPtr == iclsPtr) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", Tcl_GetString(iclsPtr->namePtr), "\" cannot inherit from itself", NULL); goto inheritError; } Itcl_AppendList(&iclsPtr->bases, baseClsPtr); ItclPreserveClass(baseClsPtr); } /* * Scan through the inheritance list to make sure that no * class appears twice. */ elem = Itcl_FirstListElem(&iclsPtr->bases); while (elem) { elem2 = Itcl_NextListElem(elem); while (elem2) { if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", iclsPtr->fullNamePtr, "\" cannot inherit base class \"", cdPtr->fullNamePtr, "\" more than once", NULL); goto inheritError; } elem2 = Itcl_NextListElem(elem2); } elem = Itcl_NextListElem(elem); } /* * Add each base class and all of its base classes into * the heritage for the current class. Along the way, make * sure that no class appears twice in the heritage. */ Itcl_InitHierIter(&hier, iclsPtr); cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */ cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr != NULL) { (void) Tcl_CreateHashEntry(&iclsPtr->heritage, (char*)cdPtr, &newEntry); if (!newEntry) { break; } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); /* * Same base class found twice in the hierarchy? * Then flag error. Show the list of multiple paths * leading to the same base class. */ if (!newEntry) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); badCdPtr = cdPtr; Tcl_AppendStringsToObj(resultPtr, "class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\" inherits base class \"", Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:", NULL); cdPtr = iclsPtr; Itcl_InitStack(&stack); Itcl_PushStack(cdPtr, &stack); /* * Show paths leading to bad base class */ while (Itcl_GetStackSize(&stack) > 0) { cdPtr = (ItclClass*)Itcl_PopStack(&stack); if (cdPtr == badCdPtr) { Tcl_AppendToObj(resultPtr, "\n ", TCL_INDEX_NONE); for (i=0; i < Itcl_GetStackSize(&stack); i++) { if (Itcl_GetStackValue(&stack, i) == NULL) { cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); Tcl_AppendStringsToObj(resultPtr, Tcl_GetString(cdPtr->namePtr), "->", NULL); } } Tcl_AppendToObj(resultPtr, Tcl_GetString(badCdPtr->namePtr), TCL_INDEX_NONE); } else if (!cdPtr) { (void)Itcl_PopStack(&stack); } else { elem = Itcl_LastListElem(&cdPtr->bases); if (elem) { Itcl_PushStack(cdPtr, &stack); Itcl_PushStack(NULL, &stack); while (elem) { Itcl_PushStack(Itcl_GetListValue(elem), &stack); elem = Itcl_PrevListElem(elem); } } } } Itcl_DeleteStack(&stack); goto inheritError; } /* * At this point, everything looks good. * Finish the installation of the base classes. Update * each base class to recognize the current class as a * derived class. */ Tcl_DStringInit(&buffer); haveClasses = 0; elem = Itcl_FirstListElem(&iclsPtr->bases); Tcl_DStringAppend(&buffer, "::oo::define ", TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, " superclass", TCL_INDEX_NONE); while (elem) { baseClsPtr = (ItclClass*)Itcl_GetListValue(elem); haveClasses++; Tcl_DStringAppend(&buffer, " ", TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), TCL_INDEX_NONE); Itcl_AppendList(&baseClsPtr->derived, iclsPtr); ItclPreserveClass(iclsPtr); elem = Itcl_NextListElem(elem); } Itcl_PopCallFrame(interp); if (haveClasses) { result = Tcl_EvalEx(interp, Tcl_DStringValue(&buffer), TCL_INDEX_NONE, 0); } Tcl_DStringFree(&buffer); Itcl_BuildVirtualTables(iclsPtr); return result; /* * If the "inherit" list cannot be built properly, tear it * down and return an error. */ inheritError: Itcl_PopCallFrame(interp); elem = Itcl_FirstListElem(&iclsPtr->bases); while (elem) { ItclReleaseClass( (ItclClass *)Itcl_GetListValue(elem) ); elem = Itcl_DeleteListElem(elem); } return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_ClassProtectionCmd() * * Invoked by Tcl whenever the user issues a protection setting * command like "public" or "private". Creates commands and * variables, and assigns a protection level to them. Protection * levels are defined as follows: * * public => accessible from any namespace * protected => accessible from selected namespaces * private => accessible only in the namespace where it was defined * * Handles the following syntax: * * public ? ...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_ClassProtectionCmd( void *clientData, /* protection level (public/protected/private) */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData; int result; int oldLevel; ItclShowArgs(2, "Itcl_ClassProtectionCmd", objc, objv); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); return TCL_ERROR; } oldLevel = Itcl_Protection(interp, pInfo->pLevel); if (objc == 2) { /* something like: public { variable a; variable b } */ result = Tcl_EvalObjEx(interp, objv[1], 0); } else { /* something like: public variable a 123 456 */ result = Itcl_EvalArgs(interp, objc-1, objv+1); } if (result == TCL_BREAK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"break\" outside of a loop", TCL_INDEX_NONE)); result = TCL_ERROR; } else { if (result == TCL_CONTINUE) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"continue\" outside of a loop", TCL_INDEX_NONE)); result = TCL_ERROR; } else { if (result != TCL_OK) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); Tcl_Obj *key = Tcl_NewStringObj("-errorline", TCL_INDEX_NONE); Tcl_Obj *stackTrace = NULL; Tcl_IncrRefCount(key); Tcl_DictObjGet(NULL, options, key, &stackTrace); Tcl_DecrRefCount(key); if (stackTrace == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n error while parsing class \"%s\"", Tcl_GetString(objv[0]))); } else { char *token = Tcl_GetString(objv[0]); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%.100s body line %s)", token, Tcl_GetString(stackTrace))); } } } } Itcl_Protection(interp, oldLevel); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassConstructorCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "constructor" command is invoked to define the constructor * for an object. Handles the following syntax: * * constructor ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassConstructorCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_Obj *namePtr; char *arglist; char *body; ItclShowArgs(2, "Itcl_ClassConstructorCmd", objc, objv); if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::constructor called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[0]; if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objv[0])) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * If there is an object initialization statement, pick this * out and take the last argument as the constructor body. */ arglist = Tcl_GetString(objv[1]); if (objc == 3) { body = Tcl_GetString(objv[2]); } else { iclsPtr->initCode = objv[2]; Tcl_IncrRefCount(iclsPtr->initCode); body = Tcl_GetString(objv[3]); } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassDestructorCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "destructor" command is invoked to define the destructor * for an object. Handles the following syntax: * * destructor * * ------------------------------------------------------------------------ */ int Itcl_ClassDestructorCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_Obj *namePtr; char *body; ItclShowArgs(2, "Itcl_ClassDestructorCmd", objc, objv); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::destructor called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[0]; body = Tcl_GetString(objv[1]); if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, NULL, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "method" command is invoked to define an object method. * Handles the following syntax: * * method ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassMethodCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); char *arglist; char *body; ItclShowArgs(2, "Itcl_ClassMethodCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::method called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[1]; hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "method \"", Tcl_GetString(namePtr), "\" has been delegated", NULL); return TCL_ERROR; } arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassProcCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "proc" command is invoked to define a common class proc. * A "proc" is like a "method", but only has access to "common" * class variables. Handles the following syntax: * * proc ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassProcCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; char *arglist; char *body; ItclShowArgs(1, "Itcl_ClassProcCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); namePtr = objv[1]; arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::proc called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { const char *name = Tcl_GetString(namePtr); /* check if the typemethod is already delegated */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { Tcl_AppendResult(interp, "Error in \"typemethod ", name, "...\", \"", name, "\" has been delegated", NULL); return TCL_ERROR; } } } if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "proc" command is invoked to define a common class proc. * A "proc" is like a "method", but only has access to "common" * class variables. Handles the following syntax: * * typemethod ?? ?? * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeMethodCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; char *arglist; char *body; ItclMemberFunc *imPtr; ItclShowArgs(1, "Itcl_ClassTypeMethodCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::typemethod called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[1]; arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { const char *name = Tcl_GetString(namePtr); /* check if the typemethod is already delegated */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { Tcl_AppendResult(interp, "Error in \"typemethod ", name, "...\", \"", name, "\" has been delegated", NULL); return TCL_ERROR; } } } iclsPtr->infoPtr->functionFlags = ITCL_TYPE_METHOD; if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { iclsPtr->infoPtr->functionFlags = 0; return TCL_ERROR; } iclsPtr->infoPtr->functionFlags = 0; hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr); imPtr = (ItclMemberFunc *)Tcl_GetHashValue(hPtr); imPtr->flags |= ITCL_TYPE_METHOD; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassVariableCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "variable" command is invoked to define an instance variable. * Handles the following syntax: * * variable ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassVariableCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclVariable *ivPtr; char *init; char *config; char *arrayInitStr; const char *usageStr; int pLevel; int haveError; int haveArrayInit; int result; result = TCL_OK; haveError = 0; haveArrayInit = 0; usageStr = NULL; arrayInitStr = NULL; ItclShowArgs(1, "Itcl_ClassVariableCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::variable called from", " not within a class", NULL); return TCL_ERROR; } pLevel = Itcl_Protection(interp, 0); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (objc > 2) { if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { if (objc == 4) { arrayInitStr = Tcl_GetString(objv[3]); haveArrayInit = 1; } else { haveError = 1; usageStr = "varname ?init|-array init?"; } } } } if (!haveError && !haveArrayInit) { if (pLevel == ITCL_PUBLIC) { if (objc < 2 || objc > 4) { usageStr = "name ?init? ?config?"; haveError = 1; } } else { if ((objc < 2) || (objc > 3)) { usageStr = "name ?init?"; haveError = 1; } } } if (haveError) { Tcl_WrongNumArgs(interp, 1, objv, usageStr); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ namePtr = objv[1]; if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", NULL); return TCL_ERROR; } init = NULL; config = NULL; if (!haveArrayInit) { if (objc >= 3) { init = Tcl_GetString(objv[2]); } if (objc >= 4) { config = Tcl_GetString(objv[3]); } } if (Itcl_CreateVariable(interp, iclsPtr, namePtr, init, config, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { ivPtr->flags |= ITCL_VARIABLE; } if (haveArrayInit) { ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, TCL_INDEX_NONE); Tcl_IncrRefCount(ivPtr->arrayInitPtr); } else { ivPtr->arrayInitPtr = NULL; } iclsPtr->numVariables++; ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); return result; } /* * ------------------------------------------------------------------------ * ItclInitClassCommon() * * initialize a class commen variable * * ------------------------------------------------------------------------ */ static int ItclInitClassCommon( Tcl_Interp *interp, ItclClass *iclsPtr, ItclVariable *ivPtr, const char *initStr) { Tcl_DString buffer; Tcl_CallFrame frame; Tcl_Namespace *commonNsPtr; Tcl_HashEntry *hPtr; Tcl_Var varPtr; int result; int isNew; result = TCL_OK; ivPtr->flags |= ITCL_COMMON; iclsPtr->numCommons++; /* * Create the variable in the namespace associated with the * class. Do this the hard way, to avoid the variable resolver * procedures. These procedures won't work until we rebuild * the virtual tables below. */ Tcl_DStringInit(&buffer); if (ivPtr->protection != ITCL_PUBLIC) { /* public commons go to the class namespace directly the others * go to the variables namespace of the class */ Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); } Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(ivPtr->iclsPtr->oPtr))->fullName, TCL_INDEX_NONE); commonNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); if (commonNsPtr == NULL) { Tcl_AppendResult(interp, "ITCL: cannot find common variables namespace", " for class \"", Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } varPtr = Tcl_NewNamespaceVar(interp, commonNsPtr, Tcl_GetString(ivPtr->namePtr)); hPtr = Tcl_CreateHashEntry(&iclsPtr->classCommons, (char *)ivPtr, &isNew); if (isNew) { Itcl_PreserveVar(varPtr); Tcl_SetHashValue(hPtr, varPtr); } result = Itcl_PushCallFrame(interp, &frame, commonNsPtr, /* isProcCallFrame */ 0); Itcl_PopCallFrame(interp); /* * If an initialization value was specified, then initialize * the variable now, otherwise be sure the variable is uninitialized. */ if (initStr != NULL) { const char *val; val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, initStr, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", NULL); return TCL_ERROR; } } else { /* previous var-lookup in class body (in ::itcl::parser) could obtain * inherited common vars, so be sure it does not exists after new * common creation (simply remove this reference). */ Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, TCL_NAMESPACE_ONLY); } if (ivPtr->arrayInitPtr != NULL) { Tcl_Size i; Tcl_Size argc; const char **argv; const char *val; result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr), &argc, &argv); for (i = 0; i < argc; i += 2) { val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i], argv[i + 1], TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", NULL); return TCL_ERROR; } } ckfree((char *)argv); } Tcl_DStringFree(&buffer); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCommonCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "common" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * common ?? * * ------------------------------------------------------------------------ */ static int ItclClassCommonCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ int protection, ItclVariable **ivPtrPtr) { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclVariable *ivPtr; Tcl_Obj *namePtr; char *arrayInitStr; const char *usageStr; char *initStr; int haveError; int haveArrayInit; int result; result = TCL_OK; haveError = 0; haveArrayInit = 0; usageStr = NULL; arrayInitStr = NULL; *ivPtrPtr = NULL; ItclShowArgs(2, "Itcl_ClassCommonCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::common called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { if (objc > 2) { if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { if (objc == 4) { arrayInitStr = Tcl_GetString(objv[3]); haveArrayInit = 1; } else { haveError = 1; usageStr = "varname ?init|-array init?"; } } } } if (!haveError && !haveArrayInit) { if ((objc < 2) || (objc > 3)) { usageStr = "varname ?init?"; haveError = 1; } } if (haveError) { Tcl_WrongNumArgs(interp, 1, objv, usageStr); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ namePtr = objv[1]; if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", NULL); return TCL_ERROR; } initStr = NULL; if (!haveArrayInit) { if (objc >= 3) { initStr = Tcl_GetString(objv[2]); } } if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (protection != 0) { ivPtr->protection = protection; } if (haveArrayInit) { ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, TCL_INDEX_NONE); Tcl_IncrRefCount(ivPtr->arrayInitPtr); } else { ivPtr->arrayInitPtr = NULL; } *ivPtrPtr = ivPtr; result = ItclInitClassCommon(interp, iclsPtr, ivPtr, initStr); ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeVariableCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "typevariable" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * typevariable ?? * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeVariableCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclVariable *ivPtr; int result; ivPtr = NULL; ItclShowArgs(1, "Itcl_ClassTypeVariableCmd", objc, objv); result = ItclClassCommonCmd(clientData, interp, objc, objv, ITCL_PUBLIC, &ivPtr); if (ivPtr != NULL) { ivPtr->flags |= ITCL_TYPE_VARIABLE; ItclAddClassVariableDictInfo(interp, ivPtr->iclsPtr, ivPtr); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCommonCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "common" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * common ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassCommonCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclVariable *ivPtr; ItclShowArgs(2, "Itcl_ClassTypeVariableCmd", objc, objv); return ItclClassCommonCmd(clientData, interp, objc, objv, 0, &ivPtr); } /* * ------------------------------------------------------------------------ * ItclFreeParserCommandData() * * This callback will free() up memory dynamically allocated * and passed as the ClientData argument to Tcl_CreateObjCommand. * This callback is required because one can not simply pass * a pointer to the free() or ckfree() to Tcl_CreateObjCommand. * ------------------------------------------------------------------------ */ static void ItclFreeParserCommandData( void *cdata) /* client data to be destroyed */ { ckfree(cdata); } /* * ------------------------------------------------------------------------ * ItclDelObjectInfo() * * Invoked when the management info for [incr Tcl] is no longer being * used in an interpreter. This will only occur when all class * manipulation commands are removed from the interpreter. * * See also FreeItclObjectInfo() in itclBase.c * ------------------------------------------------------------------------ */ static void ItclDelObjectInfo( char* cdata) /* client data for class command */ { Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)cdata; ItclObject *ioPtr; /* * Destroy all known objects by deleting their access * commands. */ hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); while (hPtr) { ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(infoPtr->interp, ioPtr->accessCmd); /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. */ hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); /*hPtr = Tcl_NextHashEntry(&place);*/ } Tcl_DeleteHashTable(&infoPtr->objects); Tcl_DeleteHashTable(&infoPtr->frameContext); Itcl_DeleteStack(&infoPtr->clsStack); Itcl_Free(infoPtr); } /* * ------------------------------------------------------------------------ * Itcl_ClassFilterCmd() * * * ------------------------------------------------------------------------ */ static int Itcl_ClassFilterCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj **newObjv; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; int result; ItclShowArgs(1, "Itcl_ClassFilterCmd", objc, objv); infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::filter called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", "/::itcl::extendedclass. Only these can have filters", NULL); return TCL_ERROR; } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2)); newObjv[0] = Tcl_NewStringObj("::oo::define", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("filter", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[2]); memcpy(newObjv+3, objv+1, sizeof(Tcl_Obj *)*(objc-1)); ItclShowArgs(1, "Itcl_ClassFilterCmd2", objc+2, newObjv); result = Tcl_EvalObjv(interp, objc+2, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); ckfree((char *)newObjv); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassMixinCmd() * * * ------------------------------------------------------------------------ */ static int Itcl_ClassMixinCmd( TCL_UNUSED(void *), /* info for all known objects */ TCL_UNUSED(Tcl_Interp *),/* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const *objv) /* argument objects */ { ItclShowArgs(0, "Itcl_ClassMixinCmd", objc, objv); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_WidgetCmd() * * that is just a dummy command to load package ItclWidget * and then to resend the command and execute it in that package * package ItclWidget is renaming the Tcl command!! * * ------------------------------------------------------------------------ */ static int Itcl_WidgetCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr; int result; ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv); infoPtr = (ItclObjectInfo *)clientData; if (!infoPtr->itclWidgetInitted) { result = Tcl_EvalEx(interp, initWidgetScript, TCL_INDEX_NONE, 0); if (result != TCL_OK) { return result; } infoPtr->itclWidgetInitted = 1; } return Tcl_EvalObjv(interp, objc, objv, 0); } /* * ------------------------------------------------------------------------ * Itcl_WidgetAdaptorCmd() * * that is just a dummy command to load package ItclWidget * and then to resend the command and execute it in that package * package ItclWidget is renaming the Tcl command!! * * ------------------------------------------------------------------------ */ static int Itcl_WidgetAdaptorCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr; int result; ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv); infoPtr = (ItclObjectInfo *)clientData; if (!infoPtr->itclWidgetInitted) { result = Tcl_EvalEx(interp, initWidgetScript, TCL_INDEX_NONE, 0); if (result != TCL_OK) { return result; } infoPtr->itclWidgetInitted = 1; } return Tcl_EvalObjv(interp, objc, objv, 0); } /* * ------------------------------------------------------------------------ * ItclParseOption() * * Invoked by Tcl during the parsing whenever * the "option" command is invoked to define an option * Handles the following syntax: * * option * * ------------------------------------------------------------------------ */ int ItclParseOption( TCL_UNUSED(ItclObjectInfo *), /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ size_t objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclClass *iclsPtr, ItclObject *ioPtr, ItclOption **ioptPtrPtr) /* where the otpion info is found */ { Tcl_Obj *classNamePtr; Tcl_Obj *nameSpecPtr; Tcl_Obj **newObjv; Tcl_HashEntry *hPtr; ItclOption *ioptPtr; char *init; char *defaultValue; char *cgetMethod; char *cgetMethodVar; char *configureMethod; char *configureMethodVar; char *validateMethod; char *validateMethodVar; const char *token; const char *usage; const char *optionName; const char **argv; const char *name; const char *resourceName; const char *className; Tcl_Size argc; int pLevel; int readOnly; int newObjc; int foundOption; int result; size_t i; const char *cp; ItclShowArgs(1, "ItclParseOption", objc, objv); pLevel = Itcl_Protection(interp, 0); usage = "namespec \ ?init? \ ?-default value? \ ?-readonly? \ ?-cgetmethod methodName? \ ?-cgetmethodvar varName? \ ?-configuremethod methodName? \ ?-configuremethodvar varName? \ ?-validatemethod methodName? \ ?-validatemethodvar varName"; if (pLevel == ITCL_PUBLIC) { if (objc < 2 || objc > 11) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } } else { if ((objc < 2) || (objc > 12)) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } } argv = NULL; newObjv = NULL; defaultValue = NULL; cgetMethod = NULL; configureMethod = NULL; validateMethod = NULL; cgetMethodVar = NULL; configureMethodVar = NULL; validateMethodVar = NULL; readOnly = 0; newObjc = 0; optionName = Tcl_GetString(objv[1]); if (iclsPtr != NULL) { /* check for already delegated!! */ hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "cannot define option \"", optionName, "\" locally, it has already been delegated", NULL); result = TCL_ERROR; goto errorOut; } } if (ioPtr != NULL) { /* check for already delegated!! */ hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "cannot define option \"", optionName, "\" locally, it has already been delegated", NULL); result = TCL_ERROR; goto errorOut; } } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*objc); newObjv[newObjc] = objv[1]; newObjc++; for (i=2; i 1) { resourceName = argv[1]; } else { /* resource name defaults to option name minus hyphen */ resourceName = name+1; } if (argc > 2) { className = argv[2]; } else { /* class name defaults to option name minus hyphen and capitalized */ className = resourceName; } classNamePtr = ItclCapitalize(className); init = defaultValue; if ((newObjc > 1) && (init == NULL)) { init = Tcl_GetString(newObjv[1]); } ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption)); ioptPtr->protection = Itcl_Protection(interp, 0); if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) { ioptPtr->protection = ITCL_PROTECTED; } ioptPtr->namePtr = Tcl_NewStringObj(name, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->namePtr); ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->resourceNamePtr); ioptPtr->classNamePtr = Tcl_NewStringObj(Tcl_GetString(classNamePtr), TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->classNamePtr); Tcl_DecrRefCount(classNamePtr); if (init) { ioptPtr->defaultValuePtr = Tcl_NewStringObj(init, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->defaultValuePtr); } if (cgetMethod != NULL) { ioptPtr->cgetMethodPtr = Tcl_NewStringObj(cgetMethod, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->cgetMethodPtr); } if (configureMethod != NULL) { ioptPtr->configureMethodPtr = Tcl_NewStringObj(configureMethod, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->configureMethodPtr); } if (validateMethod != NULL) { ioptPtr->validateMethodPtr = Tcl_NewStringObj(validateMethod, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->validateMethodPtr); } if (cgetMethodVar != NULL) { ioptPtr->cgetMethodVarPtr = Tcl_NewStringObj(cgetMethodVar, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->cgetMethodVarPtr); } if (configureMethodVar != NULL) { ioptPtr->configureMethodVarPtr = Tcl_NewStringObj(configureMethodVar, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->configureMethodVarPtr); } if (validateMethodVar != NULL) { ioptPtr->validateMethodVarPtr = Tcl_NewStringObj(validateMethodVar, TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->validateMethodVarPtr); } if (readOnly != 0) { ioptPtr->flags |= ITCL_OPTION_READONLY; } *ioptPtrPtr = ioptPtr; ItclAddOptionDictInfo(interp, iclsPtr, ioptPtr); result = TCL_OK; errorOut: if (argv != NULL) { ckfree((char *)argv); } if (newObjv != NULL) { ckfree((char *)newObjv); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassOptionCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "option" command is invoked to define an option * Handles the following syntax: * * option * * ------------------------------------------------------------------------ */ int Itcl_ClassOptionCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclOption *ioptPtr; const char *tkPackage; const char *tkVersion; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclShowArgs(1, "Itcl_ClassOptionCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::option called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "a \"class\" cannot have options", NULL); return TCL_ERROR; } if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) { tkVersion = "8.6"; tkPackage = Tcl_PkgPresentEx(interp, "Tk", tkVersion, 0, NULL); if (tkPackage == NULL) { tkPackage = Tcl_PkgRequireEx(interp, "Tk", tkVersion, 0, NULL); } if (tkPackage == NULL) { Tcl_AppendResult(interp, "cannot load package Tk", tkVersion, NULL); return TCL_ERROR; } return Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL); } if (ItclParseOption(infoPtr, interp, objc, objv, iclsPtr, NULL, &ioptPtr) != TCL_OK) { return TCL_ERROR; } if (Itcl_CreateOption(interp, iclsPtr, ioptPtr) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclCreateComponent() * * * ------------------------------------------------------------------------ */ int ItclCreateComponent( Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *componentPtr, int type, ItclComponent **icPtrPtr) { Tcl_HashEntry *hPtr; ItclComponent *icPtr; ItclVariable *ivPtr; int result; int isNew; if (iclsPtr == NULL) { return TCL_OK; } hPtr = Tcl_CreateHashEntry(&iclsPtr->components, (char *)componentPtr, &isNew); if (isNew) { if (Itcl_CreateVariable(interp, iclsPtr, componentPtr, NULL, NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (type & ITCL_COMMON) { result = ItclInitClassCommon(interp, iclsPtr, ivPtr, ""); if (result != TCL_OK) { return result; } } if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (strcmp(Tcl_GetString(componentPtr), "itcl_hull") == 0) { /* special built in itcl_hull variable */ ivPtr->initted = 1; ivPtr->flags |= ITCL_HULL_VAR; } } ivPtr->flags |= ITCL_COMPONENT_VAR; icPtr = (ItclComponent *)ckalloc(sizeof(ItclComponent)); memset(icPtr, 0, sizeof(ItclComponent)); Tcl_InitObjHashTable(&icPtr->keptOptions); icPtr->namePtr = componentPtr; Tcl_IncrRefCount(icPtr->namePtr); icPtr->ivPtr = ivPtr; Tcl_SetHashValue(hPtr, icPtr); ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); } else { icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } *icPtrPtr = icPtr; return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclHandleClassComponent() * * Invoked by Tcl during the parsing of a class definition whenever * the "component" command is invoked to define a component * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int ItclHandleClassComponent( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclComponent **icPtrPtr) { Tcl_Obj **newObjv; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclComponent *icPtr; const char *usage; const char *publ; int inherit; int haveInherit; int havePublic; int newObjc; int haveValue; int storageClass; int i; ItclShowArgs(1, "Itcl_ClassComponentCmd", objc, objv); if (icPtrPtr != NULL) { *icPtrPtr = NULL; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::component called from", " not within a class", NULL); return TCL_ERROR; } usage = "component ?-public ? ?-inherit ???"; if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::extendedclass/::itcl::widget", "/::itcl::widgetadaptor/::itcl::type.", " Only these can have components", NULL); return TCL_ERROR; } if ((objc < 2) || (objc > 6)) { Tcl_AppendResult(interp, "wrong # args should be: ", usage, NULL); return TCL_ERROR; } inherit = 0; haveInherit = 0; publ = NULL; havePublic = 0; for (i = 2; i < objc; i += 2) { if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) { if (haveInherit) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } haveValue = 0; inherit = 1; if (i < objc - 1) { if (strcmp(Tcl_GetString(objv[i + 1]), "yes") == 0) { haveValue = 1; } if (strcmp(Tcl_GetString(objv[i + 1]), "YES") == 0) { haveValue = 1; } if (strcmp(Tcl_GetString(objv[i + 1]), "no") == 0) { haveValue = 1; inherit = 0; } if (strcmp(Tcl_GetString(objv[i + 1]), "NO") == 0) { haveValue = 1; inherit = 0; } } if (haveValue) { i++; } haveInherit = 1; } else { if (strcmp(Tcl_GetString(objv[i]), "-public") == 0) { if (havePublic) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } havePublic = 1; if (i >= objc - 1) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } publ = Tcl_GetString(objv[i + 1]); } else { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } } } storageClass = ITCL_COMMON; if (iclsPtr->flags & ITCL_ECLASS) { storageClass = 0; } if (ItclCreateComponent(interp, iclsPtr, objv[1], storageClass, &icPtr) != TCL_OK) { return TCL_ERROR; } if (inherit) { icPtr->flags |= ITCL_COMPONENT_INHERIT; newObjc = 4; newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); newObjv[0] = Tcl_NewStringObj("delegate::option", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj("*", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("to", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[2]); newObjv[3] = objv[1]; Tcl_IncrRefCount(newObjv[3]); if (Itcl_ClassDelegateOptionCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(newObjv[0] , "delegate::method", TCL_INDEX_NONE); if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); Tcl_DecrRefCount(newObjv[3]); ckfree((char *)newObjv); } if (publ != NULL) { icPtr->flags |= ITCL_COMPONENT_PUBLIC; newObjc = 4; newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); newObjv[0] = Tcl_NewStringObj("delegate::method", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj(publ, TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("to", TCL_INDEX_NONE); Tcl_IncrRefCount(newObjv[2]); newObjv[3] = objv[1]; Tcl_IncrRefCount(newObjv[3]); ItclShowArgs(1, "COMPPUB", newObjc, newObjv); if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); Tcl_DecrRefCount(newObjv[3]); ckfree((char *)newObjv); } if (icPtrPtr != NULL) { *icPtrPtr = icPtr; } ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassComponentCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "component" command is invoked to define a component * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int Itcl_ClassComponentCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclComponent *icPtr; return ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeComponentCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "typecomponent" command is invoked to define a typecomponent * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeComponentCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclComponent *icPtr; int result; ItclShowArgs(1, "Itcl_ClassTypeComponentCmd", objc, objv); result = ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); if (result != TCL_OK) { return result; } icPtr->ivPtr->flags |= ITCL_COMMON; return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclCreateDelegatedFunction() * * Install a delegated function for a class * * ------------------------------------------------------------------------ */ int ItclCreateDelegatedFunction( Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *methodNamePtr, ItclComponent *icPtr, Tcl_Obj *targetPtr, Tcl_Obj *usingPtr, Tcl_Obj *exceptionsPtr, ItclDelegatedFunction **idmPtrPtr) { ItclDelegatedFunction *idmPtr; const char **argv; Tcl_Size argc; int isNew; Tcl_Size i; idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction)); memset(idmPtr, 0, sizeof(ItclDelegatedFunction)); Tcl_InitObjHashTable(&idmPtr->exceptions); idmPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(methodNamePtr), TCL_INDEX_NONE); Tcl_IncrRefCount(idmPtr->namePtr); idmPtr->icPtr = icPtr; idmPtr->asPtr = targetPtr; if (idmPtr->asPtr != NULL) { Tcl_IncrRefCount(idmPtr->asPtr); } idmPtr->usingPtr = usingPtr; if (idmPtr->usingPtr != NULL) { Tcl_IncrRefCount(idmPtr->usingPtr); } if (exceptionsPtr != NULL) { if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv) != TCL_OK) { return TCL_ERROR; } for(i = 0; i < argc; i++) { Tcl_Obj *objPtr; objPtr = Tcl_NewStringObj(argv[i], TCL_INDEX_NONE); Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr, &isNew); } ckfree((char *) argv); } if (idmPtrPtr != NULL) { *idmPtrPtr = idmPtr; } ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_HandleDelegateMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate method" command is invoked to define a * Handles the following syntax: * * delegate method * * ------------------------------------------------------------------------ */ int Itcl_HandleDelegateMethodCmd( Tcl_Interp *interp, /* current interpreter */ ItclObject *ioPtr, /* != NULL for ::itcl::adddelegatedmethod otherwise NULL */ ItclClass *iclsPtr, /* != NULL for delegate method otherwise NULL */ ItclDelegatedFunction **idmPtrPtr, /* where to return idoPtr */ Tcl_Size objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *methodNamePtr; Tcl_Obj *componentPtr; Tcl_Obj *targetPtr; Tcl_Obj *usingPtr; Tcl_Obj *exceptionsPtr; Tcl_HashEntry *hPtr; ItclClass *iclsPtr2; ItclComponent *icPtr; ItclHierIter hier; const char *usageStr; const char *methodName; const char *component; const char *token; int result; Tcl_Size i; int foundOpt; ItclShowArgs(1, "Itcl_HandleDelegateMethodCmd", objc, objv); usageStr = "delegate method to ?as ?\n\ delegate method ?to ? using \n\ delegate method * ?to ? ?using ? ?except ?"; if (objc < 4) { Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); return TCL_ERROR; } componentPtr = NULL; icPtr = NULL; methodName = Tcl_GetString(objv[1]); component = NULL; targetPtr = NULL; usingPtr = NULL; exceptionsPtr = NULL; for(i=2;iobjectDelegatedFunctions, (char *) methodNamePtr); } else { hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *) methodNamePtr); } hPtr = NULL; if (ioPtr != NULL) { if (componentPtr != NULL) { Itcl_InitHierIter(&hier, ioPtr->iclsPtr); while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); } } else { if (componentPtr != NULL) { iclsPtr2 = iclsPtr; Itcl_InitHierIter(&hier, iclsPtr2); while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr2->components, (char *)componentPtr); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); } } if (hPtr == NULL) { if (componentPtr != NULL) { if (ItclCreateComponent(interp, iclsPtr, componentPtr, ITCL_COMMON, &icPtr) != TCL_OK) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr); } } if (hPtr != NULL) { icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } if (*methodName != '*') { /* FIXME !!! */ /* check for locally defined method */ hPtr = NULL; if (ioPtr != NULL) { } else { /* FIXME !! have to check the hierarchy !! */ hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)methodNamePtr); } if (hPtr != NULL) { Tcl_AppendResult(interp, "method \"", methodName, "\" has been defined locally", NULL); result = TCL_ERROR; goto errorOut; } } result = ItclCreateDelegatedFunction(interp, iclsPtr, methodNamePtr, icPtr, targetPtr, usingPtr, exceptionsPtr, idmPtrPtr); (*idmPtrPtr)->flags |= ITCL_METHOD; errorOut: Tcl_DecrRefCount(methodNamePtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassDelegateMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate method" command is invoked to define a * Handles the following syntax: * * delegate method * * ------------------------------------------------------------------------ */ static int Itcl_ClassDelegateMethodCmd( void *clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; int isNew; int result; ItclShowArgs(1, "Itcl_ClassDelegateMethodCmd", objc, objv); infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatemethod called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", "/::itcl::extendedclass.", " Only these can delegate methods", NULL); return TCL_ERROR; } result = Itcl_HandleDelegateMethodCmd(interp, NULL, iclsPtr, &idmPtr, objc, objv); if (result != TCL_OK) { return result; } idmPtr->flags |= ITCL_METHOD; hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, (char *)idmPtr->namePtr, &isNew); Tcl_SetHashValue(hPtr, idmPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_HandleDelegateOptionCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate option" command is invoked to define a delegated option * or if ::itcl::adddelegatedoption is called with an itcl object * Handles the following syntax: * * delegate option ... * * ------------------------------------------------------------------------ */ int Itcl_HandleDelegateOptionCmd( Tcl_Interp *interp, /* current interpreter */ ItclObject *ioPtr, /* != NULL for ::itcl::adddelgatedoption otherwise NULL */ ItclClass *iclsPtr, /* != NULL for delegate option otherwise NULL */ ItclDelegatedOption **idoPtrPtr, /* where to return idoPtr */ Tcl_Size objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *allOptionNamePtr; Tcl_Obj *optionNamePtr; Tcl_Obj *componentPtr; Tcl_Obj *targetPtr; Tcl_Obj *exceptionsPtr; Tcl_Obj *resourceNamePtr; Tcl_Obj *classNamePtr; Tcl_HashEntry *hPtr; ItclComponent *icPtr; ItclClass *iclsPtr2; ItclDelegatedOption *idoPtr; ItclHierIter hier; const char *usageStr; const char *option; const char *component; const char *token; const char **argv; int foundOpt; Tcl_Size argc; int isStarOption; int isNew; Tcl_Size i; const char *cp; ItclShowArgs(1, "Itcl_HandleDelegatedOptionCmd", objc, objv); usageStr = " to ?as