/* * ------------------------------------------------------------------------ * 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. * * These procedures handle class definitions. Classes are composed of * data members (public/protected/common) and the member functions * (methods/procs) that operate on them. Each class has its own * namespace which manages the class scope. * * ======================================================================== * 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) 2007 * ======================================================================== * 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 Tcl_NamespaceDeleteProc* _TclOONamespaceDeleteProc = NULL; static void ItclDeleteOption(char *cdata); /* * FORWARD DECLARATIONS */ static void ItclDestroyClass(void *cdata); static void ItclFreeClass (void* cdata); static void ItclDeleteFunction(ItclMemberFunc *imPtr); static void ItclDeleteComponent(ItclComponent *icPtr); static void ItclDeleteOption(char *cdata); void ItclPreserveClass( ItclClass *iclsPtr) { iclsPtr->refCount++; } void ItclReleaseClass( void *clientData) { ItclClass *iclsPtr = (ItclClass *)clientData; assert(iclsPtr->refCount > 0); if (iclsPtr->refCount-- <= 1) { ItclFreeClass(clientData); } } /* * ------------------------------------------------------------------------ * Itcl_DeleteMemberFunc() * * ------------------------------------------------------------------------ */ void Itcl_DeleteMemberFunc ( void *cdata) { /* needed for stubs compatibility */ ItclMemberFunc *imPtr; imPtr = (ItclMemberFunc *)cdata; if (imPtr == NULL) { /* FIXME need code here */ } ItclDeleteFunction((ItclMemberFunc *)cdata); } /* * ------------------------------------------------------------------------ * ItclDestroyClass2() * * ------------------------------------------------------------------------ */ static void ItclDestroyClass2( void *clientData) /* The class being deleted. */ { ItclClass *iclsPtr = (ItclClass *)clientData; ItclDestroyClassNamesp(iclsPtr); ItclReleaseClass(iclsPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteClassMetadata() * * Delete the metadata data if any *------------------------------------------------------------------------- */ void ItclDeleteClassMetadata( void *clientData) { /* * This is how we get alerted from TclOO that the object corresponding * to an Itcl class (or its namespace...) is being torn down. */ ItclClass *iclsPtr = (ItclClass *)clientData; Tcl_Object oPtr = iclsPtr->oPtr; Tcl_Namespace *ooNsPtr = Tcl_GetObjectNamespace(oPtr); if (ooNsPtr != iclsPtr->nsPtr) { /* * Itcl's idea of the class namespace is different from that of TclOO. * Make sure both get torn down and pulled from tables. */ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, (char *)ooNsPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteNamespace(iclsPtr->nsPtr); } else { ItclDestroyClass2(iclsPtr); } } static int CallNewObjectInstance( void *data[], Tcl_Interp *interp, TCL_UNUSED(int)) { ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[0]; const char *path = (const char *)data[1]; Tcl_Object *oPtr = (Tcl_Object *)data[2]; Tcl_Obj *nameObjPtr = (Tcl_Obj *)data[3]; *oPtr = NULL; if (infoPtr->clazzClassPtr) { *oPtr = Tcl_NewObjectInstance(interp, infoPtr->clazzClassPtr, path, Tcl_FindNamespace(interp, path, NULL, 0) ? NULL : path, 0, NULL, 0); } if (*oPtr == NULL) { Tcl_AppendResult(interp, "ITCL: cannot create Tcl_NewObjectInstance for class \"", Tcl_GetString(nameObjPtr), "\"", NULL); return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateClass() * * Creates a namespace and its associated class definition data. * If a namespace already exists with that name, then this routine * returns TCL_ERROR, along with an error message in the interp. * If successful, it returns TCL_OK and a pointer to the new class * definition. * ------------------------------------------------------------------------ */ int Itcl_CreateClass( Tcl_Interp* interp, /* interpreter that will contain new class */ const char* path, /* name of new class */ ItclObjectInfo *infoPtr, /* info for all known objects */ ItclClass **rPtr) /* returns: pointer to class definition */ { const char *head; const char *tail; Tcl_DString buffer; Tcl_Command cmd; Tcl_CmdInfo cmdInfo; Tcl_Namespace *classNs, *ooNs; Tcl_Object oPtr; Tcl_Obj *nameObjPtr; Tcl_Obj *namePtr; ItclClass *iclsPtr; ItclVariable *ivPtr; Tcl_HashEntry *hPtr; void *callbackPtr; int result; int newEntry; ItclResolveInfo *resolveInfoPtr; if (infoPtr->clazzObjectPtr == NULL) { Tcl_AppendResult(interp, "oo-subsystem is deleted", NULL); return TCL_ERROR; } /* * check for an empty class name to avoid a crash */ if (strlen(path) == 0) { Tcl_AppendResult(interp, "invalid class name \"\"", NULL); return TCL_ERROR; } /* * Make sure that a class with the given name does not * already exist in the current namespace context. If a * namespace exists, that's okay. It may have been created * to contain stubs during a "namespace import" operation. * We'll just replace the namespace data below with the * proper class data. */ classNs = Tcl_FindNamespace(interp, (const char *)path, NULL, /* flags */ 0); if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", path, "\" already exists", NULL); return TCL_ERROR; } oPtr = NULL; /* * Make sure that a command with the given class name does not * already exist in the current namespace. This prevents the * usual Tcl commands from being clobbered when a programmer * makes a bogus call like "class info". */ cmd = Tcl_FindCommand(interp, (const char *)path, NULL, /* flags */ TCL_NAMESPACE_ONLY); if (cmd != NULL && !Itcl_IsStub(cmd)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "command \"", path, "\" already exists", NULL); if (strstr(path,"::") == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " in namespace \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", NULL); } return TCL_ERROR; } /* * Make sure that the class name does not have any goofy * characters: * * . => reserved for member access like: class.publicVar */ Itcl_ParseNamespPath(path, &buffer, &head, &tail); if (strstr(tail,".")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad class name \"", tail, "\"", NULL); Tcl_DStringFree(&buffer); return TCL_ERROR; } Tcl_DStringFree(&buffer); /* * Allocate class definition data. */ iclsPtr = (ItclClass*)ckalloc(sizeof(ItclClass)); memset(iclsPtr, 0, sizeof(ItclClass)); iclsPtr->interp = interp; iclsPtr->infoPtr = infoPtr; Itcl_PreserveData(infoPtr); Tcl_InitObjHashTable(&iclsPtr->variables); Tcl_InitObjHashTable(&iclsPtr->functions); Tcl_InitObjHashTable(&iclsPtr->options); Tcl_InitObjHashTable(&iclsPtr->components); Tcl_InitObjHashTable(&iclsPtr->delegatedOptions); Tcl_InitObjHashTable(&iclsPtr->delegatedFunctions); Tcl_InitObjHashTable(&iclsPtr->methodVariables); Tcl_InitObjHashTable(&iclsPtr->resolveCmds); iclsPtr->numInstanceVars = 0; Tcl_InitHashTable(&iclsPtr->classCommons, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&iclsPtr->resolveVars, TCL_STRING_KEYS); Tcl_InitHashTable(&iclsPtr->contextCache, TCL_ONE_WORD_KEYS); Itcl_InitList(&iclsPtr->bases); Itcl_InitList(&iclsPtr->derived); resolveInfoPtr = (ItclResolveInfo *) ckalloc(sizeof(ItclResolveInfo)); memset(resolveInfoPtr, 0, sizeof(ItclResolveInfo)); resolveInfoPtr->flags = ITCL_RESOLVE_CLASS; resolveInfoPtr->iclsPtr = iclsPtr; iclsPtr->resolvePtr = (Tcl_Resolve *)ckalloc(sizeof(Tcl_Resolve)); iclsPtr->resolvePtr->cmdProcPtr = Itcl_CmdAliasProc; iclsPtr->resolvePtr->varProcPtr = Itcl_VarAliasProc; iclsPtr->resolvePtr->clientData = resolveInfoPtr; iclsPtr->flags = infoPtr->currClassFlags; /* * Initialize the heritage info--each class starts with its * own class definition in the heritage. Base classes are * added to the heritage from the "inherit" statement. */ Tcl_InitHashTable(&iclsPtr->heritage, TCL_ONE_WORD_KEYS); (void) Tcl_CreateHashEntry(&iclsPtr->heritage, (char*)iclsPtr, &newEntry); /* * Create a namespace to represent the class. Add the class * definition info as client data for the namespace. If the * namespace already exists, then replace any existing client * data with the class data. */ ItclPreserveClass(iclsPtr); nameObjPtr = Tcl_NewStringObj("", 0); Tcl_IncrRefCount(nameObjPtr); if ((path[0] != ':') || (path[1] != ':')) { Tcl_Namespace *currNsPtr = Tcl_GetCurrentNamespace(interp); Tcl_AppendToObj(nameObjPtr, currNsPtr->fullName, TCL_INDEX_NONE); if (currNsPtr->parentPtr != NULL) { Tcl_AppendToObj(nameObjPtr, "::", 2); } } Tcl_AppendToObj(nameObjPtr, path, TCL_INDEX_NONE); { /* * TclOO machinery will refuse to overwrite an existing command * with creation of a new object. However, Itcl has a legacy * "stubs" auto-importing mechanism that explicitly needs such * overwriting. So, check whether we have a stub, and if so, * delete it before TclOO has a chance to object. */ Tcl_Command oldCmd = Tcl_FindCommand(interp, path, NULL, 0); if (Itcl_IsStub(oldCmd)) { Tcl_DeleteCommandFromToken(interp, oldCmd); } } callbackPtr = Itcl_GetCurrentCallbackPtr(interp); /* * Create a command in the current namespace to manage the class: * * ?? */ Tcl_NRAddCallback(interp, CallNewObjectInstance, infoPtr, (void *)path, &oPtr, nameObjPtr); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result == TCL_ERROR) { result = TCL_ERROR; goto errorOut; } iclsPtr->clsPtr = Tcl_GetObjectAsClass(oPtr); iclsPtr->oPtr = oPtr; ItclPreserveClass(iclsPtr); Tcl_ObjectSetMetadata(iclsPtr->oPtr, infoPtr->class_meta_type, iclsPtr); cmd = Tcl_GetObjectCommand(iclsPtr->oPtr); Tcl_GetCommandInfoFromToken(cmd, &cmdInfo); cmdInfo.deleteProc = ItclDestroyClass; cmdInfo.deleteData = iclsPtr; Tcl_SetCommandInfoFromToken(cmd, &cmdInfo); ooNs = Tcl_GetObjectNamespace(oPtr); classNs = Tcl_FindNamespace(interp, Tcl_GetString(nameObjPtr), NULL, /* flags */ 0); if (_TclOONamespaceDeleteProc == NULL) { _TclOONamespaceDeleteProc = ooNs->deleteProc; } if (classNs == NULL) { Tcl_AppendResult(interp, "ITCL: cannot create/get class namespace for class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } if (iclsPtr->infoPtr->useOldResolvers) { Itcl_SetNamespaceResolvers(ooNs, (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); Itcl_SetNamespaceResolvers(classNs, (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); } else { Tcl_SetNamespaceResolver(ooNs, iclsPtr->resolvePtr); Tcl_SetNamespaceResolver(classNs, iclsPtr->resolvePtr); } iclsPtr->nsPtr = classNs; iclsPtr->namePtr = Tcl_NewStringObj(classNs->name, TCL_INDEX_NONE); Tcl_IncrRefCount(iclsPtr->namePtr); iclsPtr->fullNamePtr = Tcl_NewStringObj(classNs->fullName, TCL_INDEX_NONE); Tcl_IncrRefCount(iclsPtr->fullNamePtr); hPtr = Tcl_CreateHashEntry(&infoPtr->nameClasses, (char *)iclsPtr->fullNamePtr, &newEntry); Tcl_SetHashValue(hPtr, iclsPtr); hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)classNs, &newEntry); Tcl_SetHashValue(hPtr, iclsPtr); if (classNs != ooNs) { hPtr = Tcl_CreateHashEntry(&infoPtr->namespaceClasses, (char *)ooNs, &newEntry); Tcl_SetHashValue(hPtr, iclsPtr); if (classNs->clientData && classNs->deleteProc) { (*classNs->deleteProc)(classNs->clientData); } classNs->clientData = iclsPtr; classNs->deleteProc = ItclDestroyClass2; } hPtr = Tcl_CreateHashEntry(&infoPtr->classes, (char *)iclsPtr, &newEntry); Tcl_SetHashValue(hPtr, iclsPtr); /* * now build the namespace for the common private and protected variables * public variables go directly to the class namespace */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, TCL_INDEX_NONE); if ((NULL == Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, TCL_GLOBAL_ONLY)) && (NULL == Tcl_CreateNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0))) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "ITCL: cannot create variables namespace \"", Tcl_DStringValue(&buffer), "\"", NULL); result = TCL_ERROR; goto errorOut; } /* * Add the built-in "this" command to the list of function members. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, "::this", TCL_INDEX_NONE); iclsPtr->thisCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), Itcl_ThisCmd, iclsPtr, NULL); /* * Add the built-in "type" variable to the list of data members. */ if (iclsPtr->flags & ITCL_TYPE) { namePtr = Tcl_NewStringObj("type", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_TYPE_VAR; /* mark as "type" variable */ } if (iclsPtr->flags & (ITCL_ECLASS)) { namePtr = Tcl_NewStringObj("win", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { namePtr = Tcl_NewStringObj("self", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELF_VAR; /* mark as "self" variable */ namePtr = Tcl_NewStringObj("selfns", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_SELFNS_VAR; /* mark as "selfns" variable */ namePtr = Tcl_NewStringObj("win", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_WIN_VAR; /* mark as "win" variable */ } namePtr = Tcl_NewStringObj("this", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ if (infoPtr->currClassFlags & (ITCL_ECLASS|ITCL_TYPE|ITCL_WIDGETADAPTOR|ITCL_WIDGET)) { /* * Add the built-in "itcl_options" variable to the list of * data members. */ namePtr = Tcl_NewStringObj("itcl_options", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTIONS_VAR; /* mark as "itcl_options" * variable */ } if (infoPtr->currClassFlags & ITCL_ECLASS) { /* * Add the built-in "itcl_option_components" variable to the list of * data members. */ namePtr = Tcl_NewStringObj("itcl_option_components", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_OPTION_COMP_VAR; /* mark as "itcl_option_components" * variable */ } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* * Add the built-in "thiswin" variable to the list of data members. */ namePtr = Tcl_NewStringObj("thiswin", TCL_INDEX_NONE); (void) Itcl_CreateVariable(interp, iclsPtr, namePtr, NULL, NULL, &ivPtr); ivPtr->protection = ITCL_PROTECTED; /* always "protected" */ ivPtr->flags |= ITCL_THIS_VAR; /* mark as "thiswin" variable */ } if (infoPtr->currClassFlags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* create the itcl_hull component */ ItclComponent *icPtr; namePtr = Tcl_NewStringObj("itcl_hull", 9); /* itcl_hull must not be an ITCL_COMMON!! */ if (ItclCreateComponent(interp, iclsPtr, namePtr, 0, &icPtr) != TCL_OK) { result = TCL_ERROR; goto errorOut; } } ItclPreserveClass(iclsPtr); iclsPtr->accessCmd = Tcl_GetObjectCommand(oPtr); /* FIXME should set the class objects unknown command to Itcl_HandleClass */ *rPtr = iclsPtr; result = TCL_OK; errorOut: Tcl_DecrRefCount(nameObjPtr); return result; } /* * ------------------------------------------------------------------------ * ItclDeleteClassVariablesNamespace() * * ------------------------------------------------------------------------ */ void ItclDeleteClassVariablesNamespace( TCL_UNUSED(Tcl_Interp *), TCL_UNUSED(ItclClass *)) { /* TODO: why is this being skipped? */ return; } static int CallDeleteOneObject( void *data[], Tcl_Interp *interp, int result) { Tcl_HashEntry *hPtr; Tcl_HashSearch place; ItclClass *iclsPtr2 = NULL; ItclObject *contextIoPtr; ItclClass *iclsPtr = (ItclClass *)data[0]; ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[1]; void *callbackPtr; int classIsDeleted; if (result != TCL_OK) { return result; } classIsDeleted = 0; hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); if (hPtr == NULL) { classIsDeleted = 1; } if (classIsDeleted) { return result; } /* * 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); if (hPtr) { contextIoPtr = (ItclObject*)Tcl_GetHashValue(hPtr); while (contextIoPtr->iclsPtr != iclsPtr) { hPtr = Tcl_NextHashEntry(&place); if (hPtr == NULL) { break; } } if (hPtr) { callbackPtr = Itcl_GetCurrentCallbackPtr(interp); if (Itcl_DeleteObject(interp, contextIoPtr) != TCL_OK) { iclsPtr2 = iclsPtr; goto deleteClassFail; } Tcl_NRAddCallback(interp, CallDeleteOneObject, iclsPtr, infoPtr, NULL, NULL); return Itcl_NRRunCallbacks(interp, callbackPtr); } } return TCL_OK; deleteClassFail: /* check if class is not yet deleted */ hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr2); if (hPtr != NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while deleting class \"%s\")", iclsPtr2->nsPtr->fullName)); } return TCL_ERROR; } static int CallDeleteOneClass( void *data[], Tcl_Interp *interp, int result) { Tcl_HashEntry *hPtr; ItclClass *iclsPtr = (ItclClass *)data[0]; ItclObjectInfo *infoPtr = (ItclObjectInfo *)data[1]; int isDerivedReleased; if (result != TCL_OK) { return result; } isDerivedReleased = iclsPtr->flags & ITCL_CLASS_DERIVED_RELEASED; result = Itcl_DeleteClass(interp, iclsPtr); if (!isDerivedReleased) { if (result == TCL_OK) { hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); if (hPtr != NULL) { /* release from derived reference */ ItclReleaseClass(iclsPtr); } } } if (result == TCL_OK) { return TCL_OK; } Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while deleting class \"%s\")", iclsPtr->nsPtr->fullName)); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_DeleteClass() * * Deletes a class by deleting all derived classes and all objects in * that class, and finally, by destroying the class namespace. This * procedure provides a friendly way of doing this. If any errors * are detected along the way, the process is aborted. * * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_DeleteClass( Tcl_Interp *interp, /* interpreter managing this class */ ItclClass *iclsPtr) /* class */ { Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr2 = NULL; Itcl_ListElem *elem; void *callbackPtr; int result; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->classes, (char *)iclsPtr); if (hPtr == NULL) { /* class has already been deleted */ return TCL_OK; } if (iclsPtr->flags & ITCL_CLASS_IS_DELETED) { return TCL_OK; } iclsPtr->flags |= ITCL_CLASS_IS_DELETED; /* * Destroy all derived classes, since these lose their meaning * when the base class goes away. If anything goes wrong, * abort with an error. * * TRICKY NOTE: When a derived class is destroyed, it * automatically deletes itself from the "derived" list. */ elem = Itcl_FirstListElem(&iclsPtr->derived); while (elem) { iclsPtr2 = (ItclClass*)Itcl_GetListValue(elem); elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ callbackPtr = Itcl_GetCurrentCallbackPtr(interp); Tcl_NRAddCallback(interp, CallDeleteOneClass, iclsPtr2, iclsPtr2->infoPtr, NULL, NULL); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result != TCL_OK) { return result; } } /* * Scan through and find all objects that belong to this class. * Note that more specialized objects have already been * destroyed above, when derived classes were destroyed. * Destroy objects and report any errors. */ /* * we have to enroll the while loop to fit for NRE * so we add a callback to delete the first element * and run this callback. At the end of the execution of that callback * we add eventually a callback for the next element and run that etc ... * if an error occurs we terminate the enrolled loop and return * otherwise we return at the end of the enrolled loop. */ callbackPtr = Itcl_GetCurrentCallbackPtr(interp); Tcl_NRAddCallback(interp, CallDeleteOneObject, iclsPtr, iclsPtr->infoPtr, NULL, NULL); result = Itcl_NRRunCallbacks(interp, callbackPtr); if (result != TCL_OK) { return result; } /* * Destroy the namespace associated with this class. * * TRICKY NOTE: * The cleanup procedure associated with the namespace is * invoked automatically. It does all of the same things * above, but it also disconnects this class from its * base-class lists, and removes the class access command. */ ItclDeleteClassVariablesNamespace(interp, iclsPtr); Tcl_DeleteNamespace(iclsPtr->nsPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclDestroyClass() * * Invoked whenever the access command for a class is destroyed. * Destroys the namespace associated with the class, which also * destroys all objects in the class and all derived classes. * Disconnects this class from the "derived" class lists of its * base classes, and releases any claim to the class definition * data. If this is the last use of that data, the class will * completely vanish at this point. * ------------------------------------------------------------------------ */ static void ItclDestroyClass( void *cdata) /* class definition to be destroyed */ { ItclClass *iclsPtr = (ItclClass*)cdata; if (iclsPtr->flags & ITCL_CLASS_IS_DESTROYED) { return; } iclsPtr->flags |= ITCL_CLASS_IS_DESTROYED; if (!(iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED)) { if (iclsPtr->accessCmd) { Tcl_DeleteCommandFromToken(iclsPtr->interp, iclsPtr->accessCmd); iclsPtr->accessCmd = NULL; } Tcl_DeleteNamespace(iclsPtr->nsPtr); } ItclReleaseClass(iclsPtr); } /* * ------------------------------------------------------------------------ * ItclDestroyClassNamesp() * * Invoked whenever the namespace associated with a class is destroyed. * Destroys all objects associated with this class and all derived * classes. Disconnects this class from the "derived" class lists * of its base classes, and removes the class access command. Releases * any claim to the class definition data. If this is the last use * of that data, the class will completely vanish at this point. * ------------------------------------------------------------------------ */ void ItclDestroyClassNamesp( void *cdata) /* class definition to be destroyed */ { Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Command cmdPtr; ItclClass *iclsPtr; ItclObject *ioPtr; Itcl_ListElem *elem; Itcl_ListElem *belem; ItclClass *iclsPtr2; ItclClass *basePtr; ItclClass *derivedPtr; iclsPtr = (ItclClass*)cdata; if (iclsPtr->flags & ITCL_CLASS_NS_IS_DESTROYED) { return; } iclsPtr->flags |= ITCL_CLASS_NS_IS_DESTROYED; /* * Destroy all derived classes, since these lose their meaning * when the base class goes away. * * TRICKY NOTE: When a derived class is destroyed, it * automatically deletes itself from the "derived" list. */ elem = Itcl_FirstListElem(&iclsPtr->derived); while (elem) { iclsPtr2 = (ItclClass*)Itcl_GetListValue(elem); if (iclsPtr2->nsPtr != NULL) { Tcl_DeleteNamespace(iclsPtr2->nsPtr); } /* As the first namespace is now destroyed we have to get the * new first element of the hash table. We cannot go to the * next element from the current one, because the current one * is deleted. itcl Patch #593112, for Bug #577719. */ elem = Itcl_FirstListElem(&iclsPtr->derived); } /* * Scan through and find all objects that belong to this class. * Destroy them quietly by deleting their access command. */ hPtr = Tcl_FirstHashEntry(&iclsPtr->infoPtr->objects, &place); while (hPtr) { ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); if (ioPtr->iclsPtr == iclsPtr) { if ((ioPtr->accessCmd != NULL) && (!(ioPtr->flags & (ITCL_OBJECT_IS_DESTRUCTED)))) { Itcl_PreserveData(ioPtr); Tcl_DeleteCommandFromToken(iclsPtr->interp, ioPtr->accessCmd); ioPtr->accessCmd = NULL; Itcl_ReleaseData(ioPtr); /* * 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(&iclsPtr->infoPtr->objects, &place); continue; } } hPtr = Tcl_NextHashEntry(&place); } /* * Now there are no objects and inherited classes anymore, they could access a * private/protected common variables, so delete the internal namespace. */ { Tcl_DString buffer; Tcl_Namespace *nsPtr; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(iclsPtr->oPtr))->fullName, TCL_INDEX_NONE); nsPtr = Tcl_FindNamespace(iclsPtr->interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); if (nsPtr != NULL) { Tcl_DeleteNamespace(nsPtr); } } /* * Next, remove this class from the "derived" list in * all base classes. */ belem = Itcl_FirstListElem(&iclsPtr->bases); while (belem) { basePtr = (ItclClass*)Itcl_GetListValue(belem); elem = Itcl_FirstListElem(&basePtr->derived); while (elem) { derivedPtr = (ItclClass*)Itcl_GetListValue(elem); if (derivedPtr == iclsPtr) { derivedPtr->flags |= ITCL_CLASS_DERIVED_RELEASED; ItclReleaseClass(derivedPtr); elem = Itcl_DeleteListElem(elem); } else { elem = Itcl_NextListElem(elem); } } belem = Itcl_NextListElem(belem); } /* * Next, destroy the access command associated with the class. */ iclsPtr->flags |= ITCL_CLASS_NS_TEARDOWN; if (iclsPtr->accessCmd) { cmdPtr = iclsPtr->accessCmd; iclsPtr->accessCmd = NULL; Tcl_DeleteCommandFromToken(iclsPtr->interp, cmdPtr); } /* * Release the namespace's claim on the class definition. */ ItclReleaseClass(iclsPtr); } /* * ------------------------------------------------------------------------ * ItclFreeClass() * * Frees all memory associated with a class definition. This is * usually invoked automatically by Itcl_ReleaseData(), when class * data is no longer being used. * ------------------------------------------------------------------------ */ static void ItclFreeClass( void *cdata) /* class definition to be destroyed */ { FOREACH_HASH_DECLS; Tcl_HashSearch place; ItclClass *iclsPtr; ItclMemberFunc *imPtr; ItclVariable *ivPtr; ItclOption *ioptPtr; ItclComponent *icPtr; ItclDelegatedOption *idoPtr; ItclDelegatedFunction *idmPtr; Itcl_ListElem *elem; ItclVarLookup *vlookup; ItclCmdLookup *clookupPtr; Tcl_Var var; iclsPtr = (ItclClass*)cdata; if (iclsPtr->flags & ITCL_CLASS_IS_FREED) { return; } ItclDeleteClassesDictInfo(iclsPtr->interp, iclsPtr); iclsPtr->flags |= ITCL_CLASS_IS_FREED; /* * Tear down the list of derived classes. This list should * really be empty if everything is working properly, but * release it here just in case. */ elem = Itcl_FirstListElem(&iclsPtr->derived); while (elem) { ItclReleaseClass( Itcl_GetListValue(elem) ); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&iclsPtr->derived); /* * Tear down the variable resolution table. Some records * appear multiple times in the table (for x, foo::x, etc.) * so each one has a reference count. */ /* Tcl_InitHashTable(&varTable, TCL_STRING_KEYS); */ FOREACH_HASH_VALUE(vlookup, &iclsPtr->resolveVars) { if (--vlookup->usage == 0) { /* * If this is a common variable owned by this class, * then release the class's hold on it. FIXME !!! */ ckfree((char*)vlookup); } } Tcl_DeleteHashTable(&iclsPtr->resolveVars); /* * Tear down the virtual method table... */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); if (hPtr == NULL) { break; } clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); ckfree((char *)clookupPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&iclsPtr->resolveCmds); /* * Delete all option definitions. */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->options, &place); if (hPtr == NULL) { break; } ioptPtr = (ItclOption *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); Itcl_ReleaseData(ioptPtr); } Tcl_DeleteHashTable(&iclsPtr->options); /* * Delete all function definitions. */ FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { imPtr->iclsPtr = NULL; Itcl_ReleaseData(imPtr); } Tcl_DeleteHashTable(&iclsPtr->functions); /* * Delete all delegated options. */ FOREACH_HASH_VALUE(idoPtr, &iclsPtr->delegatedOptions) { Itcl_ReleaseData(idoPtr); } Tcl_DeleteHashTable(&iclsPtr->delegatedOptions); /* * Delete all delegated functions. */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if ((idmPtr->icPtr == NULL) || (idmPtr->icPtr->ivPtr->iclsPtr == iclsPtr)) { ItclDeleteDelegatedFunction(idmPtr); } } Tcl_DeleteHashTable(&iclsPtr->delegatedFunctions); /* * Delete all components */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->components, &place); if (hPtr == NULL) { break; } icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (icPtr != NULL) { ItclDeleteComponent(icPtr); } } Tcl_DeleteHashTable(&iclsPtr->components); /* * Delete all variable definitions. */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->variables, &place); if (hPtr == NULL) { break; } ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (ivPtr != NULL) { Itcl_ReleaseData(ivPtr); } } Tcl_DeleteHashTable(&iclsPtr->variables); /* * Release the claim on all base classes. */ elem = Itcl_FirstListElem(&iclsPtr->bases); while (elem) { ItclReleaseClass( Itcl_GetListValue(elem) ); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&iclsPtr->bases); Tcl_DeleteHashTable(&iclsPtr->heritage); /* remove owerself from the all classes entry */ hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->nameClasses, (char *)iclsPtr->fullNamePtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } /* remove owerself from the all namespaceClasses entry */ hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, (char *)iclsPtr->nsPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } /* remove owerself from the all classes entry */ hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->classes, (char *)iclsPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } /* FIXME !!! free contextCache free resolvePtr -- this is only needed for CallFrame Resolvers -- not used at the moment */ FOREACH_HASH_VALUE(var, &iclsPtr->classCommons) { Itcl_ReleaseVar(var); } Tcl_DeleteHashTable(&iclsPtr->classCommons); /* * Free up the widget class name */ if (iclsPtr->widgetClassPtr != NULL) { Tcl_DecrRefCount(iclsPtr->widgetClassPtr); } /* * Free up the widget hulltype name */ if (iclsPtr->hullTypePtr != NULL) { Tcl_DecrRefCount(iclsPtr->hullTypePtr); } /* * Free up the type typeconstrutor code */ if (iclsPtr->typeConstructorPtr != NULL) { Tcl_DecrRefCount(iclsPtr->typeConstructorPtr); } /* * Free up the object initialization code. */ if (iclsPtr->initCode) { Tcl_DecrRefCount(iclsPtr->initCode); } Itcl_ReleaseData(iclsPtr->infoPtr); Tcl_DecrRefCount(iclsPtr->namePtr); Tcl_DecrRefCount(iclsPtr->fullNamePtr); if (iclsPtr->resolvePtr != NULL) { ckfree((char *)iclsPtr->resolvePtr->clientData); ckfree((char *)iclsPtr->resolvePtr); } ckfree(iclsPtr); } /* * ------------------------------------------------------------------------ * Itcl_IsClassNamespace() * * Checks to see whether or not the given namespace represents an * [incr Tcl] class. Returns non-zero if so, and zero otherwise. * ------------------------------------------------------------------------ */ int Itcl_IsClassNamespace( Tcl_Namespace *nsPtr) /* namespace being tested */ { ItclClass *iclsPtr = ItclNamespace2Class(nsPtr); return iclsPtr != NULL; } /* * ------------------------------------------------------------------------ * Itcl_IsClass() * * Checks the given Tcl command to see if it represents an itcl class. * Returns non-zero if the command is associated with a class. * ------------------------------------------------------------------------ */ int Itcl_IsClass( Tcl_Command cmd) /* command being tested */ { Tcl_CmdInfo cmdInfo; if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) == 0) { return 0; } if (cmdInfo.deleteProc == ItclDestroyClass) { return 1; } /* * This may be an imported command. Try to get the real * command and see if it represents a class. */ cmd = Tcl_GetOriginalCommand(cmd); if (cmd != NULL) { if (Tcl_GetCommandInfoFromToken(cmd, &cmdInfo) == 0) { return 0; } if (cmdInfo.deleteProc == ItclDestroyClass) { return 1; } } return 0; } /* * ------------------------------------------------------------------------ * Itcl_FindClass() * * Searches for the specified class in the active namespace. If the * class is found, this procedure returns a pointer to the class * definition. Otherwise, if the autoload flag is non-zero, an * attempt will be made to autoload the class definition. If it * still can't be found, this procedure returns NULL, along with an * error message in the interpreter. * ------------------------------------------------------------------------ */ ItclClass* Itcl_FindClass( Tcl_Interp* interp, /* interpreter containing class */ const char* path, /* path name for class */ int autoload) { /* * Search for a namespace with the specified name, and if * one is found, see if it is a class namespace. */ Tcl_Namespace* classNs = Itcl_FindClassNamespace(interp, path); if (classNs) { ItclObjectInfo *infoPtr = (ItclObjectInfo *) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *) classNs); if (hPtr) { return (ItclClass *) Tcl_GetHashValue(hPtr); } } /* * If the autoload flag is set, try to autoload the class * definition, then search again. */ if (autoload) { Tcl_DString buf; Tcl_DStringInit(&buf); Tcl_DStringAppend(&buf, "::auto_load ", TCL_INDEX_NONE); Tcl_DStringAppend(&buf, path, TCL_INDEX_NONE); if (Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while attempting to autoload class \"%s\")", path)); Tcl_DStringFree(&buf); return NULL; } Tcl_ResetResult(interp); Tcl_DStringFree(&buf); return Itcl_FindClass(interp, path, 0); } Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", NULL); return NULL; } /* * ------------------------------------------------------------------------ * Itcl_FindClassNamespace() * * Searches for the specified class namespace. The normal Tcl procedure * Tcl_FindNamespace also searches for namespaces, but only in the * current namespace context. This makes it hard to find one class * from within another. For example, suppose. you have two namespaces * Foo and Bar. If you're in the context of Foo and you look for * Bar, you won't find it with Tcl_FindNamespace. This behavior is * okay for namespaces, but wrong for classes. * * This procedure search for a class namespace. If the name is * absolute (i.e., starts with "::"), then that one name is checked, * and the class is either found or not. But if the name is relative, * it is sought in the current namespace context and in the global * context, just like the normal command lookup. * * This procedure returns a pointer to the desired namespace, or * NULL if the namespace was not found. * ------------------------------------------------------------------------ */ Tcl_Namespace* Itcl_FindClassNamespace( Tcl_Interp* interp, /* interpreter containing class */ const char* path) /* path name for class */ { Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); Tcl_Namespace *classNs = Tcl_FindNamespace(interp, path, NULL, 0); if ( !classNs /* We didn't find it... */ && contextNs->parentPtr != NULL /* context is not global */ && (*path != ':' || *(path+1) != ':') /* path not FQ */ ) { if (strcmp(contextNs->name, path) == 0) { classNs = contextNs; } else { classNs = Tcl_FindNamespace(interp, path, NULL, TCL_GLOBAL_ONLY); } } return classNs; } static int FinalizeCreateObject( void *data[], Tcl_Interp *interp, int result) { Tcl_Obj *objNamePtr = (Tcl_Obj *)data[0]; ItclClass *iclsPtr = (ItclClass *)data[1]; if (result == TCL_OK) { if (!(iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR))) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(objNamePtr), NULL); } } Tcl_DecrRefCount(objNamePtr); return result; } static int CallCreateObject( void *data[], Tcl_Interp *interp, int result) { Tcl_Obj *objNamePtr = (Tcl_Obj *)data[0]; ItclClass *iclsPtr = (ItclClass *)data[1]; Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; if (result == TCL_OK) { result = ItclCreateObject(interp, Tcl_GetString(objNamePtr), iclsPtr, objc, objv); } return result; } /* * ------------------------------------------------------------------------ * Itcl_HandleClass() * * first argument is ::itcl::parser::handleClass * Invoked by Tcl whenever the user issues the command associated with * a class name. Handles the following syntax: * * * ?...? * * Without any arguments, the command does nothing. In the olden days, * this allowed the class name to be invoked by itself to prompt the * autoloader to load the class definition. Today, this behavior is * retained for backward compatibility with old releases. * * If arguments are specified, then this procedure creates a new * object named in the appropriate class. Note that if * contains "#auto", that part is automatically replaced * by a unique string built from the class name. * ------------------------------------------------------------------------ */ int Itcl_HandleClass( void *clientData, /* class definition */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { if (objc > 3) { const char *token = Tcl_GetString(objv[3]); const char *nsEnd = NULL; const char *pos = token; const char *tail = pos; int fq = 0; int code = TCL_OK; Tcl_Obj *nsObj, *fqObj; while ((pos = strstr(pos, "::"))) { if (pos == token) { fq = 1; nsEnd = token; } else if (pos[-1] != ':') { nsEnd = pos - 1; } tail = pos + 2; pos++; } if (fq) { nsObj = Tcl_NewStringObj(token, nsEnd-token); } else { Tcl_Namespace *nsPtr = Tcl_GetCurrentNamespace(interp); nsObj = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); if (nsEnd) { Tcl_AppendToObj(nsObj, "::", 2); Tcl_AppendToObj(nsObj, token, nsEnd-token); } } fqObj = Tcl_DuplicateObj(nsObj); Tcl_AppendToObj(fqObj, "::", 2); Tcl_AppendToObj(fqObj, tail, TCL_INDEX_NONE); if (Tcl_GetCommandFromObj(interp, fqObj)) { Tcl_AppendResult(interp, "command \"", tail, "\" already exists in namespace \"", Tcl_GetString(nsObj), "\"", NULL); code = TCL_ERROR; } Tcl_DecrRefCount(fqObj); Tcl_DecrRefCount(nsObj); if (code != TCL_OK) { return code; } } return ItclClassCreateObject(clientData, interp, objc, objv); } int ItclClassCreateObject( void *clientData, /* IclObjectInfo */ Tcl_Interp *interp, /* current interpreter */ Tcl_Size objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_DString buffer; /* buffer used to build object names */ Tcl_Obj *objNamePtr; Tcl_HashEntry *hPtr; Tcl_Obj **newObjv; ItclClass *iclsPtr; ItclObjectInfo *infoPtr; void *callbackPtr; char unique[256]; /* buffer used for unique part of object names */ char *token; char *objName; char tmp; char *start; char *pos; const char *match; infoPtr = (ItclObjectInfo *)clientData; Tcl_ResetResult(interp); ItclShowArgs(1, "ItclClassCreateObject", objc, objv); /* * If the command is invoked without an object name, then do nothing. * This used to support autoloading--that the class name could be * invoked as a command by itself, prompting the autoloader to * load the class definition. We retain the behavior here for * backward-compatibility with earlier releases. */ if (objc <= 3) { return TCL_OK; } hPtr = Tcl_FindHashEntry(&infoPtr->nameClasses, (char *)objv[2]); if (hPtr == NULL) { Tcl_AppendResult(interp, "no such class: \"", Tcl_GetString(objv[1]), "\"", NULL); return TCL_ERROR; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * If the object name is "::", and if this is an old-style class * definition, then treat the remaining arguments as a command * in the class namespace. This used to be the way of invoking * a class proc, but the new syntax is "class::proc" (without * spaces). */ token = Tcl_GetString(objv[3]); if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 4)) { /* * If this is not an old-style class, then return an error * describing the syntax change. */ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "syntax \"class :: proc\" is an anachronism\n", "[incr Tcl] no longer supports this syntax.\n", "Instead, remove the spaces from your procedure invocations:\n", " ", Tcl_GetString(objv[1]), "::", Tcl_GetString(objv[4]), " ?args?", NULL); return TCL_ERROR; } /* * Otherwise, we have a proper object name. Create a new instance * with that name. If the name contains "#auto", replace this with * a uniquely generated string based on the class name. */ Tcl_DStringInit(&buffer); objName = NULL; match = "#auto"; start = token; for (pos=start; *pos != '\0'; pos++) { if (*pos == *match) { if (*(++match) == '\0') { tmp = *start; *start = '\0'; /* null-terminate first part */ /* * Substitute a unique part in for "#auto", and keep * incrementing a counter until a valid name is found. */ do { Tcl_CmdInfo dummy; sprintf(unique,"%.200s%" TCL_SIZE_MODIFIER "u", Tcl_GetString(iclsPtr->namePtr), iclsPtr->unique++); unique[0] = tolower(UCHAR(unique[0])); Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, token, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, unique, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, start+5, TCL_INDEX_NONE); objName = Tcl_DStringValue(&buffer); /* * [Fix 227811] Check for any command with the * given name, not only objects. */ if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { break; /* if an error is found, bail out! */ } } while (1); *start = tmp; /* undo null-termination */ objName = Tcl_DStringValue(&buffer); break; /* object name is ready to go! */ } } else { match = "#auto"; pos = start++; } } /* * If "#auto" was not found, then just use object name as-is. */ if (objName == NULL) { objName = token; } if (*objName == '\0') { Tcl_AppendResult(interp, "object name must not be empty", NULL); Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL); return TCL_ERROR; } /* * Try to create a new object. If successful, return the * object name as the result of this command. */ objNamePtr = Tcl_NewStringObj(objName, TCL_INDEX_NONE); Tcl_IncrRefCount(objNamePtr); Tcl_DStringFree(&buffer); callbackPtr = Itcl_GetCurrentCallbackPtr(interp); newObjv = (Tcl_Obj **)(objv+4); Tcl_NRAddCallback(interp, FinalizeCreateObject, objNamePtr, iclsPtr, NULL, NULL); Tcl_NRAddCallback(interp, CallCreateObject, objNamePtr, iclsPtr, INT2PTR(objc-4), newObjv); return Itcl_NRRunCallbacks(interp, callbackPtr); } /* * ------------------------------------------------------------------------ * ItclResolveVarEntry() * * Side effect: (re)build part of resolver hash-table on demand. * ------------------------------------------------------------------------ */ Tcl_HashEntry * ItclResolveVarEntry( ItclClass* iclsPtr, /* class definition where to resolve variable */ const char *lookupName) /* name of variable being resolved */ { Tcl_HashEntry *reshPtr, *hPtr; /* could be resolved directly */ if ((reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName)) != NULL) { return reshPtr; } else { /* try to build virtual table for this var */ const char *varName, *simpleName; Tcl_DString buffer, buffer2, *bufferC; ItclHierIter hier; ItclClass* iclsPtr2; ItclVarLookup *vlookup; ItclVariable *ivPtr; Tcl_Namespace* nsPtr; Tcl_Obj *vnObjPtr; int newEntry, processAncestors; Tcl_Size varLen; /* (de)qualify to simple name */ varName = simpleName = lookupName; while(*varName) { if (*varName++ == ':') { if (*varName++ == ':') { simpleName = varName; } }; } vnObjPtr = Tcl_NewStringObj(simpleName, TCL_INDEX_NONE); processAncestors = simpleName != lookupName; Tcl_DStringInit(&buffer); Tcl_DStringInit(&buffer2); /* * Scan through all classes in the hierarchy, from most to * least specific. Add a lookup entry for each variable * into the table. */ Itcl_InitHierIter(&hier, iclsPtr); iclsPtr2 = Itcl_AdvanceHierIter(&hier); while (iclsPtr2 != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr2->variables, vnObjPtr); if (hPtr) { ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr); vlookup = NULL; /* * Create all possible names for this variable and enter * them into the variable resolution table: * var * class::var * namesp1::class::var * namesp2::namesp1::class::var * ... */ varName = simpleName; varLen = -1; bufferC = &buffer; nsPtr = iclsPtr2->nsPtr; while (1) { hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveVars, varName, &newEntry); /* check for same name in current class */ if (!newEntry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (vlookup->ivPtr != ivPtr && iclsPtr2 == iclsPtr) { /* if used multiple times - unbind, else - overwrite */ if (vlookup->usage > 1) { /* correct leastQualName */ vlookup->leastQualName = NULL; processAncestors = 1; /* correction in progress */ /* should create new lookup */ --vlookup->usage; vlookup = NULL; } else { /* correct values (overwrite) */ vlookup->usage = 0; goto setResVar; } newEntry = 1; } else { /* var exists and no correction necessary - next var */ if (!processAncestors) { break; } /* check leastQualName correction needed */ if (!vlookup->leastQualName) { vlookup->leastQualName = (char *) Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); } /* reset vlookup for full-qualified names - new lookup */ if (vlookup->ivPtr != ivPtr) { vlookup = NULL; } } } if (newEntry) { if (!vlookup) { /* create new (or overwrite) */ vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup)); vlookup->usage = 0; setResVar: vlookup->ivPtr = ivPtr; vlookup->leastQualName = (char *) Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr); /* * If this variable is PRIVATE to another class scope, * then mark it as "inaccessible". */ vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE || ivPtr->iclsPtr == iclsPtr); /* * Set aside the first object-specific slot for the built-in * "this" variable. Only allocate one of these, even though * there is a definition for "this" in each class scope. * Set aside the second and third object-specific slot for the built-in * "itcl_options" and "itcl_option_components" variable. */ if (iclsPtr->numInstanceVars == 0) { iclsPtr->numInstanceVars += 3; } /* * If this is a reference to the built-in "this" * variable, then its index is "0". Otherwise, * add another slot to the end of the table. */ if ((ivPtr->flags & ITCL_THIS_VAR) != 0) { vlookup->varNum = 0; } else { if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) { vlookup->varNum = 1; } else { vlookup->varNum = iclsPtr->numInstanceVars++; } } } Tcl_SetHashValue(hPtr, vlookup); vlookup->usage++; } /* if we have found it */ if (simpleName == lookupName || strcmp(varName, lookupName) == 0) { if (!reshPtr) { reshPtr = hPtr; } break; } if (nsPtr == NULL) { break; } Tcl_DStringSetLength(bufferC, 0); Tcl_DStringAppend(bufferC, nsPtr->name, TCL_INDEX_NONE); Tcl_DStringAppend(bufferC, "::", 2); Tcl_DStringAppend(bufferC, varName, varLen); varName = Tcl_DStringValue(bufferC); varLen = Tcl_DStringLength(bufferC); bufferC = (bufferC == &buffer) ? &buffer2 : &buffer; nsPtr = nsPtr->parentPtr; } } /* Stop create vars for ancestors (if not needed) */ if (!processAncestors && reshPtr) { /* simple name - don't need to check ancestors */ break; } iclsPtr2 = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); Tcl_DStringFree(&buffer); Tcl_DStringFree(&buffer2); Tcl_DecrRefCount(vnObjPtr); if (reshPtr == NULL) { reshPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, lookupName); } return reshPtr; } } /* * ------------------------------------------------------------------------ * Itcl_BuildVirtualTables() * * Invoked whenever the class heritage changes or members are added or * removed from a class definition to rebuild the member lookup * tables. There are two tables: * * METHODS: resolveCmds * Used primarily in Itcl_ClassCmdResolver() to resolve all * command references in a namespace. * * DATA MEMBERS: resolveVars (built on demand, moved to ItclResolveVarEntry) * Used primarily in Itcl_ClassVarResolver() to quickly resolve * variable references in each class scope. * * These tables store every possible name for each command/variable * (member, class::member, namesp::class::member, etc.). Members * in a derived class may shadow members with the same name in a * base class. In that case, the simple name in the resolution * table will point to the most-specific member. * ------------------------------------------------------------------------ */ void Itcl_BuildVirtualTables( ItclClass* iclsPtr) /* class definition being updated */ { Tcl_HashEntry *hPtr; Tcl_HashSearch place; Tcl_Namespace* nsPtr; Tcl_DString buffer, buffer2, *bufferC, *bufferC2, *bufferSwp; Tcl_Obj *objPtr; ItclMemberFunc *imPtr; ItclDelegatedFunction *idmPtr; ItclHierIter hier; ItclClass *iclsPtr2; ItclCmdLookup *clookupPtr; int newEntry; Tcl_DStringInit(&buffer); Tcl_DStringInit(&buffer2); /* * Clear the command resolution table. */ while (1) { hPtr = Tcl_FirstHashEntry(&iclsPtr->resolveCmds, &place); if (hPtr == NULL) { break; } clookupPtr = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); ckfree((char *)clookupPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&iclsPtr->resolveCmds); Tcl_InitObjHashTable(&iclsPtr->resolveCmds); /* * Scan through all classes in the hierarchy, from most to * least specific. Look for the first (most-specific) definition * of each member function, and enter it into the table. */ Itcl_InitHierIter(&hier, iclsPtr); iclsPtr2 = Itcl_AdvanceHierIter(&hier); while (iclsPtr2 != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr2->functions, &place); while (hPtr) { imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); /* * Create all possible names for this function and enter * them into the command resolution table: * func * class::func * namesp1::class::func * namesp2::namesp1::class::func * ... */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, Tcl_GetString(imPtr->namePtr), TCL_INDEX_NONE); bufferC = &buffer; bufferC2 = &buffer2; nsPtr = iclsPtr2->nsPtr; while (1) { objPtr = Tcl_NewStringObj(Tcl_DStringValue(bufferC), Tcl_DStringLength(bufferC)); hPtr = Tcl_CreateHashEntry(&iclsPtr->resolveCmds, (char *)objPtr, &newEntry); if (newEntry) { clookupPtr = (ItclCmdLookup *)ckalloc(sizeof(ItclCmdLookup)); memset(clookupPtr, 0, sizeof(ItclCmdLookup)); clookupPtr->imPtr = imPtr; Tcl_SetHashValue(hPtr, clookupPtr); } else { Tcl_DecrRefCount(objPtr); } if (nsPtr == NULL) { break; } Tcl_DStringSetLength(bufferC2, 0); Tcl_DStringAppend(bufferC2, nsPtr->name, TCL_INDEX_NONE); Tcl_DStringAppend(bufferC2, "::", 2); Tcl_DStringAppend(bufferC2, Tcl_DStringValue(bufferC), Tcl_DStringLength(bufferC)); bufferSwp = bufferC; bufferC = bufferC2; bufferC2 = bufferSwp; nsPtr = nsPtr->parentPtr; } hPtr = Tcl_NextHashEntry(&place); } iclsPtr2 = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); /* * Scan through all classes in the hierarchy, from most to * least specific. Look for the first (most-specific) definition * of each delegated member function, and enter it into the table. */ Itcl_InitHierIter(&hier, iclsPtr); iclsPtr2 = Itcl_AdvanceHierIter(&hier); while (iclsPtr2 != NULL) { hPtr = Tcl_FirstHashEntry(&iclsPtr2->delegatedFunctions, &place); while (hPtr) { idmPtr = (ItclDelegatedFunction *)Tcl_GetHashValue(hPtr); hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)idmPtr->namePtr); if (hPtr == NULL) { hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, (char *)idmPtr->namePtr, &newEntry); Tcl_SetHashValue(hPtr, idmPtr); } hPtr = Tcl_NextHashEntry(&place); } iclsPtr2 = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); Tcl_DStringFree(&buffer); Tcl_DStringFree(&buffer2); } /* * ------------------------------------------------------------------------ * Itcl_CreateVariable() * * Creates a new class variable definition. If this is a public * variable, it may have a bit of "config" code that is used to * update the object whenever the variable is modified via the * built-in "configure" method. * * Returns TCL_ERROR along with an error message in the specified * interpreter if anything goes wrong. Otherwise, this returns * TCL_OK and a pointer to the new variable definition in "ivPtr". * ------------------------------------------------------------------------ */ int Itcl_CreateVariable( Tcl_Interp *interp, /* interpreter managing this transaction */ ItclClass* iclsPtr, /* class containing this variable */ Tcl_Obj* namePtr, /* variable name */ char* init, /* initial value */ char* config, /* code invoked when variable is configured */ ItclVariable** ivPtrPtr) /* returns: new variable definition */ { int newEntry; ItclVariable *ivPtr; ItclMemberCode *mCodePtr; Tcl_HashEntry *hPtr; /* * Add this variable to the variable table for the class. * Make sure that the variable name does not already exist. */ hPtr = Tcl_CreateHashEntry(&iclsPtr->variables, (char *)namePtr, &newEntry); if (!newEntry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "variable name \"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * If this variable has some "config" code, try to capture * its implementation. */ if (config) { if (Itcl_CreateMemberCode(interp, iclsPtr, NULL, config, &mCodePtr) != TCL_OK) { Tcl_DeleteHashEntry(hPtr); return TCL_ERROR; } Itcl_PreserveData(mCodePtr); } else { mCodePtr = NULL; } /* * If everything looks good, create the variable definition. */ ivPtr = (ItclVariable*)Itcl_Alloc(sizeof(ItclVariable)); ivPtr->iclsPtr = iclsPtr; ivPtr->infoPtr = iclsPtr->infoPtr; ivPtr->protection = Itcl_Protection(interp, 0); ivPtr->codePtr = mCodePtr; ivPtr->namePtr = namePtr; Tcl_IncrRefCount(ivPtr->namePtr); ivPtr->fullNamePtr = Tcl_NewStringObj( Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_AppendToObj(ivPtr->fullNamePtr, "::", 2); Tcl_AppendToObj(ivPtr->fullNamePtr, Tcl_GetString(namePtr), TCL_INDEX_NONE); Tcl_IncrRefCount(ivPtr->fullNamePtr); if (ivPtr->protection == ITCL_DEFAULT_PROTECT) { ivPtr->protection = ITCL_PROTECTED; } if (init != NULL) { ivPtr->init = Tcl_NewStringObj(init, TCL_INDEX_NONE); Tcl_IncrRefCount(ivPtr->init); } else { ivPtr->init = NULL; } Tcl_SetHashValue(hPtr, ivPtr); Itcl_PreserveData(ivPtr); Itcl_EventuallyFree(ivPtr, (Tcl_FreeProc *) Itcl_DeleteVariable); *ivPtrPtr = ivPtr; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateOption() * * Creates a new class option definition. If this is a public * option, it may have a bit of "config" code that is used to * update the object whenever the option is modified via the * built-in "configure" method. * * Returns TCL_ERROR along with an error message in the specified * interpreter if anything goes wrong. Otherwise, this returns * TCL_OK and a pointer to the new option definition in "ioptPtr". * ------------------------------------------------------------------------ */ int Itcl_CreateOption( Tcl_Interp *interp, /* interpreter managing this transaction */ ItclClass* iclsPtr, /* class containing this variable */ ItclOption* ioptPtr) /* new option definition */ { int newEntry; Tcl_HashEntry *hPtr; /* * Add this option to the options table for the class. * Make sure that the option name does not already exist. */ hPtr = Tcl_CreateHashEntry(&iclsPtr->options, (char *)ioptPtr->namePtr, &newEntry); if (!newEntry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "option name \"", Tcl_GetString(ioptPtr->namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } iclsPtr->numOptions++; ioptPtr->iclsPtr = iclsPtr; ioptPtr->codePtr = NULL; ioptPtr->fullNamePtr = Tcl_NewStringObj( Tcl_GetString(iclsPtr->fullNamePtr), TCL_INDEX_NONE); Tcl_AppendToObj(ioptPtr->fullNamePtr, "::", 2); Tcl_AppendToObj(ioptPtr->fullNamePtr, Tcl_GetString(ioptPtr->namePtr), TCL_INDEX_NONE); Tcl_IncrRefCount(ioptPtr->fullNamePtr); Tcl_SetHashValue(hPtr, ioptPtr); Itcl_PreserveData(ioptPtr); Itcl_EventuallyFree(ioptPtr, (Tcl_FreeProc *) ItclDeleteOption); return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclCreateMethodVariable() * * Creates a new class methdovariable definition. If this is a public * methodvariable, * * Returns TCL_ERROR along with an error message in the specified * interpreter if anything goes wrong. Otherwise, this returns * TCL_OK and a pointer to the new option definition in "imvPtr". * ------------------------------------------------------------------------ */ int ItclCreateMethodVariable( Tcl_Interp *interp, /* interpreter managing this transaction */ ItclVariable *ivPtr, /* variable reference (from Itcl_CreateVariable) */ Tcl_Obj* defaultPtr, /* initial value */ Tcl_Obj* callbackPtr, /* code invoked when variable is set */ ItclMethodVariable** imvPtrPtr) /* returns: new methdovariable definition */ { int isNew; ItclMethodVariable *imvPtr; Tcl_HashEntry *hPtr; /* * Add this methodvariable to the options table for the class. * Make sure that the methodvariable name does not already exist. */ hPtr = Tcl_CreateHashEntry(&ivPtr->iclsPtr->methodVariables, (char *)ivPtr->namePtr, &isNew); if (!isNew) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "methdovariable name \"", Tcl_GetString(ivPtr->namePtr), "\" already defined in class \"", Tcl_GetString (ivPtr->iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * If everything looks good, create the option definition. */ imvPtr = (ItclMethodVariable*)ckalloc(sizeof(ItclMethodVariable)); memset(imvPtr, 0, sizeof(ItclMethodVariable)); imvPtr->iclsPtr = ivPtr->iclsPtr; imvPtr->protection = Itcl_Protection(interp, 0); imvPtr->namePtr = ivPtr->namePtr; Tcl_IncrRefCount(imvPtr->namePtr); imvPtr->fullNamePtr = ivPtr->fullNamePtr; Tcl_IncrRefCount(imvPtr->fullNamePtr); imvPtr->defaultValuePtr = defaultPtr; if (defaultPtr != NULL) { Tcl_IncrRefCount(imvPtr->defaultValuePtr); } imvPtr->callbackPtr = callbackPtr; if (callbackPtr != NULL) { Tcl_IncrRefCount(imvPtr->callbackPtr); } if (imvPtr->protection == ITCL_DEFAULT_PROTECT) { imvPtr->protection = ITCL_PROTECTED; } Tcl_SetHashValue(hPtr, imvPtr); *imvPtrPtr = imvPtr; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_GetCommonVar() * * Returns the current value for a common class variable. The member * name is interpreted with respect to the given class scope. That * scope is installed as the current context before querying the * variable. This by-passes the protection level in case the variable * is "private". * * If successful, this procedure returns a pointer to a string value * which remains alive until the variable changes it value. If * anything goes wrong, this returns NULL. * ------------------------------------------------------------------------ */ const char* Itcl_GetCommonVar( Tcl_Interp *interp, /* current interpreter */ const char *name, /* name of desired instance variable */ ItclClass *contextIclsPtr) /* name is interpreted in this scope */ { const char *val = NULL; Tcl_HashEntry *hPtr; Tcl_DString buffer; Tcl_Obj *namePtr; ItclVariable *ivPtr; const char *cp; const char *lastCp; Tcl_Object oPtr = NULL; lastCp = name; cp = name; while (cp != NULL) { cp = strstr(lastCp, "::"); if (cp != NULL) { lastCp = cp + 2; } } namePtr = Tcl_NewStringObj(lastCp, TCL_INDEX_NONE); Tcl_IncrRefCount(namePtr); hPtr = Tcl_FindHashEntry(&contextIclsPtr->variables, (char *)namePtr); Tcl_DecrRefCount(namePtr); if (hPtr == NULL) { return NULL; } ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr); /* * Activate the namespace for the given class. That installs * the appropriate name resolution rules and by-passes any * security restrictions. */ if (lastCp == name) { /* 'name' is a simple name (this is untested!!!!) */ /* Use the context class passed in */ oPtr = contextIclsPtr->oPtr; } else { int code = TCL_ERROR; Tcl_Obj *classObjPtr = Tcl_NewStringObj(name, lastCp - name - 2); oPtr = Tcl_GetObjectFromObj(interp, classObjPtr); if (oPtr) { ItclClass *iclsPtr = (ItclClass *)Tcl_ObjectGetMetadata(oPtr, contextIclsPtr->infoPtr->class_meta_type); if (iclsPtr) { code = TCL_OK; assert(oPtr == iclsPtr->oPtr); /* * If the caller gave us a qualified name into * somewhere other than the context class, then * things are really weird. Consider an assertion * to prevent, but for now keep the functioning * unchanged. * * assert(iclsPtr == contextIclsPtr); */ } } Tcl_DecrRefCount(classObjPtr); if (code != TCL_OK) { return NULL; } } Tcl_DStringInit(&buffer); if (ivPtr->protection != ITCL_PUBLIC) { Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, TCL_INDEX_NONE); } Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(oPtr))->fullName, TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, "::", TCL_INDEX_NONE); Tcl_DStringAppend(&buffer, lastCp, TCL_INDEX_NONE); val = Tcl_GetVar2(interp, (const char *)Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); return val; } /* * ------------------------------------------------------------------------ * Itcl_InitHierIter() * * Initializes an iterator for traversing the hierarchy of the given * class. Subsequent calls to Itcl_AdvanceHierIter() will return * the base classes in order from most-to-least specific. * ------------------------------------------------------------------------ */ void Itcl_InitHierIter( ItclHierIter *iter, /* iterator used for traversal */ ItclClass *iclsPtr) /* class definition for start of traversal */ { Itcl_InitStack(&iter->stack); Itcl_PushStack(iclsPtr, &iter->stack); iter->current = iclsPtr; } /* * ------------------------------------------------------------------------ * Itcl_DeleteHierIter() * * Destroys an iterator for traversing class hierarchies, freeing * all memory associated with it. * ------------------------------------------------------------------------ */ void Itcl_DeleteHierIter( ItclHierIter *iter) /* iterator used for traversal */ { Itcl_DeleteStack(&iter->stack); iter->current = NULL; } /* * ------------------------------------------------------------------------ * Itcl_AdvanceHierIter() * * Moves a class hierarchy iterator forward to the next base class. * Returns a pointer to the current class definition, or NULL when * the end of the hierarchy has been reached. * ------------------------------------------------------------------------ */ ItclClass* Itcl_AdvanceHierIter( ItclHierIter *iter) /* iterator used for traversal */ { Itcl_ListElem *elem; ItclClass *iclsPtr; iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); /* * Push classes onto the stack in reverse order, so that * they will be popped off in the proper order. */ if (iter->current) { iclsPtr = (ItclClass*)iter->current; elem = Itcl_LastListElem(&iclsPtr->bases); while (elem) { Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack); elem = Itcl_PrevListElem(elem); } } return iter->current; } /* * ------------------------------------------------------------------------ * Itcl_DeleteVariable() * * Destroys a variable definition created by Itcl_CreateVariable(), * freeing all resources associated with it. * ------------------------------------------------------------------------ */ void Itcl_DeleteVariable( char *cdata) /* variable definition to be destroyed */ { Tcl_HashEntry *hPtr; ItclVariable *ivPtr; ivPtr = (ItclVariable *)cdata; hPtr = Tcl_FindHashEntry(&ivPtr->infoPtr->classes, (char *)ivPtr->iclsPtr); if (hPtr != NULL) { /* unlink owerself from list of class variables */ hPtr = Tcl_FindHashEntry(&ivPtr->iclsPtr->variables, (char *)ivPtr->namePtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } } if (ivPtr->codePtr != NULL) { Itcl_ReleaseData(ivPtr->codePtr); } Tcl_DecrRefCount(ivPtr->namePtr); Tcl_DecrRefCount(ivPtr->fullNamePtr); if (ivPtr->init) { Tcl_DecrRefCount(ivPtr->init); } if (ivPtr->arrayInitPtr) { Tcl_DecrRefCount(ivPtr->arrayInitPtr); } Itcl_Free(ivPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteOption() * * Destroys a option definition created by Itcl_CreateOption(), * freeing all resources associated with it. * ------------------------------------------------------------------------ */ static void ItclDeleteOption( char *cdata) /* option definition to be destroyed */ { ItclOption *ioptPtr; ioptPtr = (ItclOption *)cdata; Tcl_DecrRefCount(ioptPtr->namePtr); Tcl_DecrRefCount(ioptPtr->fullNamePtr); if (ioptPtr->resourceNamePtr != NULL) { Tcl_DecrRefCount(ioptPtr->resourceNamePtr); } if (ioptPtr->resourceNamePtr != NULL) { Tcl_DecrRefCount(ioptPtr->classNamePtr); } if (ioptPtr->codePtr) { Itcl_ReleaseData(ioptPtr->codePtr); } if (ioptPtr->defaultValuePtr != NULL) { Tcl_DecrRefCount(ioptPtr->defaultValuePtr); } if (ioptPtr->cgetMethodPtr != NULL) { Tcl_DecrRefCount(ioptPtr->cgetMethodPtr); } if (ioptPtr->cgetMethodVarPtr != NULL) { Tcl_DecrRefCount(ioptPtr->cgetMethodVarPtr); } if (ioptPtr->configureMethodPtr != NULL) { Tcl_DecrRefCount(ioptPtr->configureMethodPtr); } if (ioptPtr->configureMethodVarPtr != NULL) { Tcl_DecrRefCount(ioptPtr->configureMethodVarPtr); } if (ioptPtr->validateMethodPtr != NULL) { Tcl_DecrRefCount(ioptPtr->validateMethodPtr); } if (ioptPtr->validateMethodVarPtr != NULL) { Tcl_DecrRefCount(ioptPtr->validateMethodVarPtr); } Itcl_ReleaseData(ioptPtr->idoPtr); Itcl_Free(ioptPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteFunction() * * fre data associated with a function * ------------------------------------------------------------------------ */ static void ItclDeleteFunction( ItclMemberFunc *imPtr) { Tcl_HashEntry *hPtr; hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->procMethods, (char *) imPtr->tmPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } hPtr = Tcl_FindHashEntry(&imPtr->infoPtr->classes, (char *)imPtr->iclsPtr); if (hPtr != NULL) { /* unlink owerself from list of class functions */ hPtr = Tcl_FindHashEntry(&imPtr->iclsPtr->functions, (char *)imPtr->namePtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } } if (imPtr->codePtr != NULL) { Itcl_ReleaseData(imPtr->codePtr); } Tcl_DecrRefCount(imPtr->namePtr); Tcl_DecrRefCount(imPtr->fullNamePtr); if (imPtr->usagePtr != NULL) { Tcl_DecrRefCount(imPtr->usagePtr); } if (imPtr->argumentPtr != NULL) { Tcl_DecrRefCount(imPtr->argumentPtr); } if (imPtr->origArgsPtr != NULL) { Tcl_DecrRefCount(imPtr->origArgsPtr); } if (imPtr->builtinArgumentPtr != NULL) { Tcl_DecrRefCount(imPtr->builtinArgumentPtr); } if (imPtr->bodyPtr != NULL) { Tcl_DecrRefCount(imPtr->bodyPtr); } if (imPtr->argListPtr != NULL) { ItclDeleteArgList(imPtr->argListPtr); } Itcl_Free(imPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteComponent() * * free data associated with a component * ------------------------------------------------------------------------ */ static void ItclDeleteComponent( ItclComponent *icPtr) { Tcl_Obj *objPtr; FOREACH_HASH_DECLS; Tcl_DecrRefCount(icPtr->namePtr); /* the variable and the command are freed when freeing variables, * functions */ FOREACH_HASH_VALUE(objPtr, &icPtr->keptOptions) { if (objPtr != NULL) { Tcl_DecrRefCount(objPtr); } } Tcl_DeleteHashTable(&icPtr->keptOptions); ckfree((char*)icPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteDelegatedOption() * * free data associated with a delegated option * ------------------------------------------------------------------------ */ void ItclDeleteDelegatedOption( char *cdata) { Tcl_Obj *objPtr; FOREACH_HASH_DECLS; ItclDelegatedOption *idoPtr; idoPtr = (ItclDelegatedOption *)cdata; Tcl_DecrRefCount(idoPtr->namePtr); if (idoPtr->resourceNamePtr != NULL) { Tcl_DecrRefCount(idoPtr->resourceNamePtr); } if (idoPtr->classNamePtr != NULL) { Tcl_DecrRefCount(idoPtr->classNamePtr); } if (idoPtr->asPtr != NULL) { Tcl_DecrRefCount(idoPtr->asPtr); } FOREACH_HASH_VALUE(objPtr, &idoPtr->exceptions) { if (objPtr != NULL) { Tcl_DecrRefCount(objPtr); } } Tcl_DeleteHashTable(&idoPtr->exceptions); Itcl_Free(idoPtr); } /* * ------------------------------------------------------------------------ * ItclDeleteDelegatedFunction() * * free data associated with a delegated function * ------------------------------------------------------------------------ */ void ItclDeleteDelegatedFunction( ItclDelegatedFunction *idmPtr) { Tcl_Obj *objPtr; FOREACH_HASH_DECLS; Tcl_DecrRefCount(idmPtr->namePtr); if (idmPtr->asPtr != NULL) { Tcl_DecrRefCount(idmPtr->asPtr); } if (idmPtr->usingPtr != NULL) { Tcl_DecrRefCount(idmPtr->usingPtr); } FOREACH_HASH_VALUE(objPtr, &idmPtr->exceptions) { if (objPtr != NULL) { Tcl_DecrRefCount(objPtr); } } Tcl_DeleteHashTable(&idmPtr->exceptions); ckfree((char *)idmPtr); }