/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* PACKAGE: [incr Tcl]
|
* PACKAGE: [incr Tcl]
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
*
|
*
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* C++ provides object-oriented extensions to C. It provides a means
|
* C++ provides object-oriented extensions to C. It provides a means
|
* of encapsulating related procedures together with their shared data
|
* of encapsulating related procedures together with their shared data
|
* in a local namespace that is hidden from the outside world. It
|
* in a local namespace that is hidden from the outside world. It
|
* promotes code re-use through inheritance. More than anything else,
|
* promotes code re-use through inheritance. More than anything else,
|
* it encourages better organization of Tcl applications through the
|
* it encourages better organization of Tcl applications through the
|
* object-oriented paradigm, leading to code that is easier to
|
* object-oriented paradigm, leading to code that is easier to
|
* understand and maintain.
|
* understand and maintain.
|
*
|
*
|
* These procedures handle class definitions. Classes are composed of
|
* These procedures handle class definitions. Classes are composed of
|
* data members (public/protected/common) and the member functions
|
* data members (public/protected/common) and the member functions
|
* (methods/procs) that operate on them. Each class has its own
|
* (methods/procs) that operate on them. Each class has its own
|
* namespace which manages the class scope.
|
* namespace which manages the class scope.
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* AUTHOR: Michael J. McLennan
|
* AUTHOR: Michael J. McLennan
|
* Bell Labs Innovations for Lucent Technologies
|
* Bell Labs Innovations for Lucent Technologies
|
* mmclennan@lucent.com
|
* mmclennan@lucent.com
|
* http://www.tcltk.com/itcl
|
* http://www.tcltk.com/itcl
|
*
|
*
|
* RCS: $Id: itcl_class.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_class.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* ========================================================================
|
* ========================================================================
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*/
|
*/
|
#include "itclInt.h"
|
#include "itclInt.h"
|
|
|
/*
|
/*
|
* This structure is a subclass of Tcl_ResolvedVarInfo that contains the
|
* This structure is a subclass of Tcl_ResolvedVarInfo that contains the
|
* ItclVarLookup info needed at runtime.
|
* ItclVarLookup info needed at runtime.
|
*/
|
*/
|
typedef struct ItclResolvedVarInfo {
|
typedef struct ItclResolvedVarInfo {
|
Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */
|
Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */
|
ItclVarLookup *vlookup; /* Pointer to lookup info. */
|
ItclVarLookup *vlookup; /* Pointer to lookup info. */
|
} ItclResolvedVarInfo;
|
} ItclResolvedVarInfo;
|
|
|
/*
|
/*
|
* FORWARD DECLARATIONS
|
* FORWARD DECLARATIONS
|
*/
|
*/
|
static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata));
|
static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata));
|
static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata));
|
static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata));
|
static void ItclFreeClass _ANSI_ARGS_((char* cdata));
|
static void ItclFreeClass _ANSI_ARGS_((char* cdata));
|
|
|
static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_((
|
static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_((
|
Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr));
|
Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr));
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateClass()
|
* Itcl_CreateClass()
|
*
|
*
|
* Creates a namespace and its associated class definition data.
|
* Creates a namespace and its associated class definition data.
|
* If a namespace already exists with that name, then this routine
|
* If a namespace already exists with that name, then this routine
|
* returns TCL_ERROR, along with an error message in the interp.
|
* returns TCL_ERROR, along with an error message in the interp.
|
* If successful, it returns TCL_OK and a pointer to the new class
|
* If successful, it returns TCL_OK and a pointer to the new class
|
* definition.
|
* definition.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateClass(interp, path, info, rPtr)
|
Itcl_CreateClass(interp, path, info, rPtr)
|
Tcl_Interp* interp; /* interpreter that will contain new class */
|
Tcl_Interp* interp; /* interpreter that will contain new class */
|
char* path; /* name of new class */
|
char* path; /* name of new class */
|
ItclObjectInfo *info; /* info for all known objects */
|
ItclObjectInfo *info; /* info for all known objects */
|
ItclClass **rPtr; /* returns: pointer to class definition */
|
ItclClass **rPtr; /* returns: pointer to class definition */
|
{
|
{
|
char *head, *tail;
|
char *head, *tail;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
Tcl_Command cmd;
|
Tcl_Command cmd;
|
Tcl_Namespace *classNs;
|
Tcl_Namespace *classNs;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
int newEntry;
|
int newEntry;
|
|
|
/*
|
/*
|
* Make sure that a class with the given name does not
|
* Make sure that a class with the given name does not
|
* already exist in the current namespace context. If a
|
* already exist in the current namespace context. If a
|
* namespace exists, that's okay. It may have been created
|
* namespace exists, that's okay. It may have been created
|
* to contain stubs during a "namespace import" operation.
|
* to contain stubs during a "namespace import" operation.
|
* We'll just replace the namespace data below with the
|
* We'll just replace the namespace data below with the
|
* proper class data.
|
* proper class data.
|
*/
|
*/
|
classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
|
classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
|
/* flags */ 0);
|
/* flags */ 0);
|
|
|
if (classNs != NULL && Itcl_IsClassNamespace(classNs)) {
|
if (classNs != NULL && Itcl_IsClassNamespace(classNs)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"class \"", path, "\" already exists",
|
"class \"", path, "\" already exists",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that a command with the given class name does not
|
* Make sure that a command with the given class name does not
|
* already exist in the current namespace. This prevents the
|
* already exist in the current namespace. This prevents the
|
* usual Tcl commands from being clobbered when a programmer
|
* usual Tcl commands from being clobbered when a programmer
|
* makes a bogus call like "class info".
|
* makes a bogus call like "class info".
|
*/
|
*/
|
cmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL,
|
cmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL,
|
/* flags */ TCL_NAMESPACE_ONLY);
|
/* flags */ TCL_NAMESPACE_ONLY);
|
|
|
if (cmd != NULL && !Itcl_IsStub(cmd)) {
|
if (cmd != NULL && !Itcl_IsStub(cmd)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"command \"", path, "\" already exists",
|
"command \"", path, "\" already exists",
|
(char*)NULL);
|
(char*)NULL);
|
|
|
if (strstr(path,"::") == NULL) {
|
if (strstr(path,"::") == NULL) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
" in namespace \"",
|
" in namespace \"",
|
Tcl_GetCurrentNamespace(interp)->fullName, "\"",
|
Tcl_GetCurrentNamespace(interp)->fullName, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the class name does not have any goofy
|
* Make sure that the class name does not have any goofy
|
* characters:
|
* characters:
|
*
|
*
|
* . => reserved for member access like: class.publicVar
|
* . => reserved for member access like: class.publicVar
|
*/
|
*/
|
Itcl_ParseNamespPath(path, &buffer, &head, &tail);
|
Itcl_ParseNamespPath(path, &buffer, &head, &tail);
|
|
|
if (strstr(tail,".")) {
|
if (strstr(tail,".")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad class name \"", tail, "\"",
|
"bad class name \"", tail, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
|
|
/*
|
/*
|
* Allocate class definition data.
|
* Allocate class definition data.
|
*/
|
*/
|
cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass));
|
cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass));
|
cdPtr->name = NULL;
|
cdPtr->name = NULL;
|
cdPtr->fullname = NULL;
|
cdPtr->fullname = NULL;
|
cdPtr->interp = interp;
|
cdPtr->interp = interp;
|
cdPtr->info = info; Itcl_PreserveData((ClientData)info);
|
cdPtr->info = info; Itcl_PreserveData((ClientData)info);
|
cdPtr->namesp = NULL;
|
cdPtr->namesp = NULL;
|
cdPtr->accessCmd = NULL;
|
cdPtr->accessCmd = NULL;
|
|
|
Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS);
|
|
|
cdPtr->numInstanceVars = 0;
|
cdPtr->numInstanceVars = 0;
|
Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS);
|
|
|
Itcl_InitList(&cdPtr->bases);
|
Itcl_InitList(&cdPtr->bases);
|
Itcl_InitList(&cdPtr->derived);
|
Itcl_InitList(&cdPtr->derived);
|
|
|
cdPtr->initCode = NULL;
|
cdPtr->initCode = NULL;
|
cdPtr->unique = 0;
|
cdPtr->unique = 0;
|
cdPtr->flags = 0;
|
cdPtr->flags = 0;
|
|
|
/*
|
/*
|
* Initialize the heritage info--each class starts with its
|
* Initialize the heritage info--each class starts with its
|
* own class definition in the heritage. Base classes are
|
* own class definition in the heritage. Base classes are
|
* added to the heritage from the "inherit" statement.
|
* added to the heritage from the "inherit" statement.
|
*/
|
*/
|
Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS);
|
Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS);
|
(void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry);
|
(void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry);
|
|
|
/*
|
/*
|
* Create a namespace to represent the class. Add the class
|
* Create a namespace to represent the class. Add the class
|
* definition info as client data for the namespace. If the
|
* definition info as client data for the namespace. If the
|
* namespace already exists, then replace any existing client
|
* namespace already exists, then replace any existing client
|
* data with the class data.
|
* data with the class data.
|
*/
|
*/
|
Itcl_PreserveData((ClientData)cdPtr);
|
Itcl_PreserveData((ClientData)cdPtr);
|
|
|
if (classNs == NULL) {
|
if (classNs == NULL) {
|
classNs = Tcl_CreateNamespace(interp, path,
|
classNs = Tcl_CreateNamespace(interp, path,
|
(ClientData)cdPtr, ItclDestroyClassNamesp);
|
(ClientData)cdPtr, ItclDestroyClassNamesp);
|
}
|
}
|
else {
|
else {
|
if (classNs->clientData && classNs->deleteProc) {
|
if (classNs->clientData && classNs->deleteProc) {
|
(*classNs->deleteProc)(classNs->clientData);
|
(*classNs->deleteProc)(classNs->clientData);
|
}
|
}
|
classNs->clientData = (ClientData)cdPtr;
|
classNs->clientData = (ClientData)cdPtr;
|
classNs->deleteProc = ItclDestroyClassNamesp;
|
classNs->deleteProc = ItclDestroyClassNamesp;
|
}
|
}
|
|
|
Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass);
|
Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass);
|
|
|
if (classNs == NULL) {
|
if (classNs == NULL) {
|
Itcl_ReleaseData((ClientData)cdPtr);
|
Itcl_ReleaseData((ClientData)cdPtr);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
cdPtr->namesp = classNs;
|
cdPtr->namesp = classNs;
|
|
|
cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1));
|
cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1));
|
strcpy(cdPtr->name, classNs->name);
|
strcpy(cdPtr->name, classNs->name);
|
|
|
cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1));
|
cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1));
|
strcpy(cdPtr->fullname, classNs->fullName);
|
strcpy(cdPtr->fullname, classNs->fullName);
|
|
|
/*
|
/*
|
* Add special name resolution procedures to the class namespace
|
* Add special name resolution procedures to the class namespace
|
* so that members are accessed according to the rules for
|
* so that members are accessed according to the rules for
|
* [incr Tcl].
|
* [incr Tcl].
|
*/
|
*/
|
Tcl_SetNamespaceResolvers(classNs, Itcl_ClassCmdResolver,
|
Tcl_SetNamespaceResolvers(classNs, Itcl_ClassCmdResolver,
|
Itcl_ClassVarResolver, Itcl_ClassCompiledVarResolver);
|
Itcl_ClassVarResolver, Itcl_ClassCompiledVarResolver);
|
|
|
/*
|
/*
|
* Add the built-in "this" variable to the list of data members.
|
* Add the built-in "this" variable to the list of data members.
|
*/
|
*/
|
(void) Itcl_CreateVarDefn(interp, cdPtr, "this",
|
(void) Itcl_CreateVarDefn(interp, cdPtr, "this",
|
(char*)NULL, (char*)NULL, &vdefn);
|
(char*)NULL, (char*)NULL, &vdefn);
|
|
|
vdefn->member->protection = ITCL_PROTECTED; /* always "protected" */
|
vdefn->member->protection = ITCL_PROTECTED; /* always "protected" */
|
vdefn->member->flags |= ITCL_THIS_VAR; /* mark as "this" variable */
|
vdefn->member->flags |= ITCL_THIS_VAR; /* mark as "this" variable */
|
|
|
entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry);
|
entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry);
|
Tcl_SetHashValue(entry, (ClientData)vdefn);
|
Tcl_SetHashValue(entry, (ClientData)vdefn);
|
|
|
/*
|
/*
|
* Create a command in the current namespace to manage the class:
|
* Create a command in the current namespace to manage the class:
|
* <className>
|
* <className>
|
* <className> <objName> ?<constructor-args>?
|
* <className> <objName> ?<constructor-args>?
|
*/
|
*/
|
Itcl_PreserveData((ClientData)cdPtr);
|
Itcl_PreserveData((ClientData)cdPtr);
|
|
|
cdPtr->accessCmd = Tcl_CreateObjCommand(interp,
|
cdPtr->accessCmd = Tcl_CreateObjCommand(interp,
|
cdPtr->fullname, Itcl_HandleClass,
|
cdPtr->fullname, Itcl_HandleClass,
|
(ClientData)cdPtr, ItclDestroyClass);
|
(ClientData)cdPtr, ItclDestroyClass);
|
|
|
*rPtr = cdPtr;
|
*rPtr = cdPtr;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteClass()
|
* Itcl_DeleteClass()
|
*
|
*
|
* Deletes a class by deleting all derived classes and all objects in
|
* Deletes a class by deleting all derived classes and all objects in
|
* that class, and finally, by destroying the class namespace. This
|
* that class, and finally, by destroying the class namespace. This
|
* procedure provides a friendly way of doing this. If any errors
|
* procedure provides a friendly way of doing this. If any errors
|
* are detected along the way, the process is aborted.
|
* are detected along the way, the process is aborted.
|
*
|
*
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* message in the interpreter) if anything goes wrong.
|
* message in the interpreter) if anything goes wrong.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_DeleteClass(interp, cdefnPtr)
|
Itcl_DeleteClass(interp, cdefnPtr)
|
Tcl_Interp *interp; /* interpreter managing this class */
|
Tcl_Interp *interp; /* interpreter managing this class */
|
ItclClass *cdefnPtr; /* class namespace */
|
ItclClass *cdefnPtr; /* class namespace */
|
{
|
{
|
ItclClass *cdPtr = NULL;
|
ItclClass *cdPtr = NULL;
|
|
|
Itcl_ListElem *elem;
|
Itcl_ListElem *elem;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
/*
|
/*
|
* Destroy all derived classes, since these lose their meaning
|
* Destroy all derived classes, since these lose their meaning
|
* when the base class goes away. If anything goes wrong,
|
* when the base class goes away. If anything goes wrong,
|
* abort with an error.
|
* abort with an error.
|
*
|
*
|
* TRICKY NOTE: When a derived class is destroyed, it
|
* TRICKY NOTE: When a derived class is destroyed, it
|
* automatically deletes itself from the "derived" list.
|
* automatically deletes itself from the "derived" list.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
while (elem) {
|
while (elem) {
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
elem = Itcl_NextListElem(elem); /* advance here--elem will go away */
|
elem = Itcl_NextListElem(elem); /* advance here--elem will go away */
|
|
|
if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) {
|
if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) {
|
goto deleteClassFail;
|
goto deleteClassFail;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through and find all objects that belong to this class.
|
* Scan through and find all objects that belong to this class.
|
* Note that more specialized objects have already been
|
* Note that more specialized objects have already been
|
* destroyed above, when derived classes were destroyed.
|
* destroyed above, when derived classes were destroyed.
|
* Destroy objects and report any errors.
|
* Destroy objects and report any errors.
|
*/
|
*/
|
entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
|
while (entry) {
|
while (entry) {
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
if (contextObj->classDefn == cdefnPtr) {
|
if (contextObj->classDefn == cdefnPtr) {
|
if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
|
if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
|
cdPtr = cdefnPtr;
|
cdPtr = cdefnPtr;
|
goto deleteClassFail;
|
goto deleteClassFail;
|
}
|
}
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
|
|
/*
|
/*
|
* Destroy the namespace associated with this class.
|
* Destroy the namespace associated with this class.
|
*
|
*
|
* TRICKY NOTE:
|
* TRICKY NOTE:
|
* The cleanup procedure associated with the namespace is
|
* The cleanup procedure associated with the namespace is
|
* invoked automatically. It does all of the same things
|
* invoked automatically. It does all of the same things
|
* above, but it also disconnects this class from its
|
* above, but it also disconnects this class from its
|
* base-class lists, and removes the class access command.
|
* base-class lists, and removes the class access command.
|
*/
|
*/
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_OK;
|
return TCL_OK;
|
|
|
deleteClassFail:
|
deleteClassFail:
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringAppend(&buffer, "\n (while deleting class \"", -1);
|
Tcl_DStringAppend(&buffer, "\n (while deleting class \"", -1);
|
Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1);
|
Tcl_DStringAppend(&buffer, "\")", -1);
|
Tcl_DStringAppend(&buffer, "\")", -1);
|
Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer));
|
Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer));
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclDestroyClass()
|
* ItclDestroyClass()
|
*
|
*
|
* Invoked whenever the access command for a class is destroyed.
|
* Invoked whenever the access command for a class is destroyed.
|
* Destroys the namespace associated with the class, which also
|
* Destroys the namespace associated with the class, which also
|
* destroys all objects in the class and all derived classes.
|
* destroys all objects in the class and all derived classes.
|
* Disconnects this class from the "derived" class lists of its
|
* Disconnects this class from the "derived" class lists of its
|
* base classes, and releases any claim to the class definition
|
* base classes, and releases any claim to the class definition
|
* data. If this is the last use of that data, the class will
|
* data. If this is the last use of that data, the class will
|
* completely vanish at this point.
|
* completely vanish at this point.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static void
|
static void
|
ItclDestroyClass(cdata)
|
ItclDestroyClass(cdata)
|
ClientData cdata; /* class definition to be destroyed */
|
ClientData cdata; /* class definition to be destroyed */
|
{
|
{
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
cdefnPtr->accessCmd = NULL;
|
cdefnPtr->accessCmd = NULL;
|
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Itcl_ReleaseData((ClientData)cdefnPtr);
|
Itcl_ReleaseData((ClientData)cdefnPtr);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclDestroyClassNamesp()
|
* ItclDestroyClassNamesp()
|
*
|
*
|
* Invoked whenever the namespace associated with a class is destroyed.
|
* Invoked whenever the namespace associated with a class is destroyed.
|
* Destroys all objects associated with this class and all derived
|
* Destroys all objects associated with this class and all derived
|
* classes. Disconnects this class from the "derived" class lists
|
* classes. Disconnects this class from the "derived" class lists
|
* of its base classes, and removes the class access command. Releases
|
* of its base classes, and removes the class access command. Releases
|
* any claim to the class definition data. If this is the last use
|
* any claim to the class definition data. If this is the last use
|
* of that data, the class will completely vanish at this point.
|
* of that data, the class will completely vanish at this point.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static void
|
static void
|
ItclDestroyClassNamesp(cdata)
|
ItclDestroyClassNamesp(cdata)
|
ClientData cdata; /* class definition to be destroyed */
|
ClientData cdata; /* class definition to be destroyed */
|
{
|
{
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
Itcl_ListElem *elem, *belem;
|
Itcl_ListElem *elem, *belem;
|
ItclClass *cdPtr, *basePtr, *derivedPtr;
|
ItclClass *cdPtr, *basePtr, *derivedPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
|
|
/*
|
/*
|
* Destroy all derived classes, since these lose their meaning
|
* Destroy all derived classes, since these lose their meaning
|
* when the base class goes away.
|
* when the base class goes away.
|
*
|
*
|
* TRICKY NOTE: When a derived class is destroyed, it
|
* TRICKY NOTE: When a derived class is destroyed, it
|
* automatically deletes itself from the "derived" list.
|
* automatically deletes itself from the "derived" list.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
while (elem) {
|
while (elem) {
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
cdPtr = (ItclClass*)Itcl_GetListValue(elem);
|
elem = Itcl_NextListElem(elem); /* advance here--elem will go away */
|
elem = Itcl_NextListElem(elem); /* advance here--elem will go away */
|
|
|
Tcl_DeleteNamespace(cdPtr->namesp);
|
Tcl_DeleteNamespace(cdPtr->namesp);
|
}
|
}
|
|
|
/*
|
/*
|
* Scan through and find all objects that belong to this class.
|
* Scan through and find all objects that belong to this class.
|
* Destroy them quietly by deleting their access command.
|
* Destroy them quietly by deleting their access command.
|
*/
|
*/
|
entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place);
|
while (entry) {
|
while (entry) {
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
if (contextObj->classDefn == cdefnPtr) {
|
if (contextObj->classDefn == cdefnPtr) {
|
Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->accessCmd);
|
Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->accessCmd);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
|
|
/*
|
/*
|
* Next, remove this class from the "derived" list in
|
* Next, remove this class from the "derived" list in
|
* all base classes.
|
* all base classes.
|
*/
|
*/
|
belem = Itcl_FirstListElem(&cdefnPtr->bases);
|
belem = Itcl_FirstListElem(&cdefnPtr->bases);
|
while (belem) {
|
while (belem) {
|
basePtr = (ItclClass*)Itcl_GetListValue(belem);
|
basePtr = (ItclClass*)Itcl_GetListValue(belem);
|
|
|
elem = Itcl_FirstListElem(&basePtr->derived);
|
elem = Itcl_FirstListElem(&basePtr->derived);
|
while (elem) {
|
while (elem) {
|
derivedPtr = (ItclClass*)Itcl_GetListValue(elem);
|
derivedPtr = (ItclClass*)Itcl_GetListValue(elem);
|
if (derivedPtr == cdefnPtr) {
|
if (derivedPtr == cdefnPtr) {
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
elem = Itcl_DeleteListElem(elem);
|
elem = Itcl_DeleteListElem(elem);
|
} else {
|
} else {
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
}
|
}
|
belem = Itcl_NextListElem(belem);
|
belem = Itcl_NextListElem(belem);
|
}
|
}
|
|
|
/*
|
/*
|
* Next, destroy the access command associated with the class.
|
* Next, destroy the access command associated with the class.
|
*/
|
*/
|
if (cdefnPtr->accessCmd) {
|
if (cdefnPtr->accessCmd) {
|
Command *cmdPtr = (Command*)cdefnPtr->accessCmd;
|
Command *cmdPtr = (Command*)cdefnPtr->accessCmd;
|
|
|
cmdPtr->deleteProc = Itcl_ReleaseData;
|
cmdPtr->deleteProc = Itcl_ReleaseData;
|
Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd);
|
Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd);
|
}
|
}
|
|
|
/*
|
/*
|
* Release the namespace's claim on the class definition.
|
* Release the namespace's claim on the class definition.
|
*/
|
*/
|
Itcl_ReleaseData((ClientData)cdefnPtr);
|
Itcl_ReleaseData((ClientData)cdefnPtr);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclFreeClass()
|
* ItclFreeClass()
|
*
|
*
|
* Frees all memory associated with a class definition. This is
|
* Frees all memory associated with a class definition. This is
|
* usually invoked automatically by Itcl_ReleaseData(), when class
|
* usually invoked automatically by Itcl_ReleaseData(), when class
|
* data is no longer being used.
|
* data is no longer being used.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static void
|
static void
|
ItclFreeClass(cdata)
|
ItclFreeClass(cdata)
|
char *cdata; /* class definition to be destroyed */
|
char *cdata; /* class definition to be destroyed */
|
{
|
{
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
ItclClass *cdefnPtr = (ItclClass*)cdata;
|
|
|
int newEntry;
|
int newEntry;
|
Itcl_ListElem *elem;
|
Itcl_ListElem *elem;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry, *hPtr;
|
Tcl_HashEntry *entry, *hPtr;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
Var *varPtr;
|
Var *varPtr;
|
Tcl_HashTable varTable;
|
Tcl_HashTable varTable;
|
|
|
/*
|
/*
|
* Tear down the list of derived classes. This list should
|
* Tear down the list of derived classes. This list should
|
* really be empty if everything is working properly, but
|
* really be empty if everything is working properly, but
|
* release it here just in case.
|
* release it here just in case.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
elem = Itcl_FirstListElem(&cdefnPtr->derived);
|
while (elem) {
|
while (elem) {
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
Itcl_DeleteList(&cdefnPtr->derived);
|
Itcl_DeleteList(&cdefnPtr->derived);
|
|
|
/*
|
/*
|
* Tear down the variable resolution table. Some records
|
* Tear down the variable resolution table. Some records
|
* appear multiple times in the table (for x, foo::x, etc.)
|
* appear multiple times in the table (for x, foo::x, etc.)
|
* so each one has a reference count.
|
* so each one has a reference count.
|
*/
|
*/
|
Tcl_InitHashTable(&varTable, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&varTable, TCL_STRING_KEYS);
|
|
|
entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
|
while (entry) {
|
while (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (--vlookup->usage == 0) {
|
if (--vlookup->usage == 0) {
|
/*
|
/*
|
* If this is a common variable owned by this class,
|
* If this is a common variable owned by this class,
|
* then release the class's hold on it. If it's no
|
* then release the class's hold on it. If it's no
|
* longer being used, move it into a variable table
|
* longer being used, move it into a variable table
|
* for destruction.
|
* for destruction.
|
*/
|
*/
|
if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 &&
|
if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 &&
|
vlookup->vdefn->member->classDefn == cdefnPtr ) {
|
vlookup->vdefn->member->classDefn == cdefnPtr ) {
|
varPtr = (Var*)vlookup->var.common;
|
varPtr = (Var*)vlookup->var.common;
|
if (--varPtr->refCount == 0) {
|
if (--varPtr->refCount == 0) {
|
hPtr = Tcl_CreateHashEntry(&varTable,
|
hPtr = Tcl_CreateHashEntry(&varTable,
|
vlookup->vdefn->member->fullname, &newEntry);
|
vlookup->vdefn->member->fullname, &newEntry);
|
Tcl_SetHashValue(hPtr, (ClientData) varPtr);
|
Tcl_SetHashValue(hPtr, (ClientData) varPtr);
|
}
|
}
|
}
|
}
|
ckfree((char*)vlookup);
|
ckfree((char*)vlookup);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
|
|
TclDeleteVars((Interp*)cdefnPtr->interp, &varTable);
|
TclDeleteVars((Interp*)cdefnPtr->interp, &varTable);
|
Tcl_DeleteHashTable(&cdefnPtr->resolveVars);
|
Tcl_DeleteHashTable(&cdefnPtr->resolveVars);
|
|
|
/*
|
/*
|
* Tear down the virtual method table...
|
* Tear down the virtual method table...
|
*/
|
*/
|
Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);
|
Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);
|
|
|
/*
|
/*
|
* Delete all variable definitions.
|
* Delete all variable definitions.
|
*/
|
*/
|
entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
Itcl_DeleteVarDefn(vdefn);
|
Itcl_DeleteVarDefn(vdefn);
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
Tcl_DeleteHashTable(&cdefnPtr->variables);
|
Tcl_DeleteHashTable(&cdefnPtr->variables);
|
|
|
/*
|
/*
|
* Delete all function definitions.
|
* Delete all function definitions.
|
*/
|
*/
|
entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place);
|
while (entry) {
|
while (entry) {
|
Itcl_ReleaseData( Tcl_GetHashValue(entry) );
|
Itcl_ReleaseData( Tcl_GetHashValue(entry) );
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
Tcl_DeleteHashTable(&cdefnPtr->functions);
|
Tcl_DeleteHashTable(&cdefnPtr->functions);
|
|
|
/*
|
/*
|
* Release the claim on all base classes.
|
* Release the claim on all base classes.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
elem = Itcl_FirstListElem(&cdefnPtr->bases);
|
while (elem) {
|
while (elem) {
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
Itcl_ReleaseData( Itcl_GetListValue(elem) );
|
elem = Itcl_NextListElem(elem);
|
elem = Itcl_NextListElem(elem);
|
}
|
}
|
Itcl_DeleteList(&cdefnPtr->bases);
|
Itcl_DeleteList(&cdefnPtr->bases);
|
Tcl_DeleteHashTable(&cdefnPtr->heritage);
|
Tcl_DeleteHashTable(&cdefnPtr->heritage);
|
|
|
/*
|
/*
|
* Free up the object initialization code.
|
* Free up the object initialization code.
|
*/
|
*/
|
if (cdefnPtr->initCode) {
|
if (cdefnPtr->initCode) {
|
Tcl_DecrRefCount(cdefnPtr->initCode);
|
Tcl_DecrRefCount(cdefnPtr->initCode);
|
}
|
}
|
|
|
Itcl_ReleaseData((ClientData)cdefnPtr->info);
|
Itcl_ReleaseData((ClientData)cdefnPtr->info);
|
|
|
ckfree(cdefnPtr->name);
|
ckfree(cdefnPtr->name);
|
ckfree(cdefnPtr->fullname);
|
ckfree(cdefnPtr->fullname);
|
|
|
ckfree((char*)cdefnPtr);
|
ckfree((char*)cdefnPtr);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_IsClassNamespace()
|
* Itcl_IsClassNamespace()
|
*
|
*
|
* Checks to see whether or not the given namespace represents an
|
* Checks to see whether or not the given namespace represents an
|
* [incr Tcl] class. Returns non-zero if so, and zero otherwise.
|
* [incr Tcl] class. Returns non-zero if so, and zero otherwise.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_IsClassNamespace(namesp)
|
Itcl_IsClassNamespace(namesp)
|
Tcl_Namespace *namesp; /* namespace being tested */
|
Tcl_Namespace *namesp; /* namespace being tested */
|
{
|
{
|
Namespace *nsPtr = (Namespace*)namesp;
|
Namespace *nsPtr = (Namespace*)namesp;
|
|
|
if (nsPtr != NULL) {
|
if (nsPtr != NULL) {
|
return (nsPtr->deleteProc == ItclDestroyClassNamesp);
|
return (nsPtr->deleteProc == ItclDestroyClassNamesp);
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_IsClass()
|
* Itcl_IsClass()
|
*
|
*
|
* Checks the given Tcl command to see if it represents an itcl class.
|
* Checks the given Tcl command to see if it represents an itcl class.
|
* Returns non-zero if the command is associated with a class.
|
* Returns non-zero if the command is associated with a class.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_IsClass(cmd)
|
Itcl_IsClass(cmd)
|
Tcl_Command cmd; /* command being tested */
|
Tcl_Command cmd; /* command being tested */
|
{
|
{
|
Command *cmdPtr = (Command*)cmd;
|
Command *cmdPtr = (Command*)cmd;
|
|
|
if (cmdPtr->deleteProc == ItclDestroyClass) {
|
if (cmdPtr->deleteProc == ItclDestroyClass) {
|
return 1;
|
return 1;
|
}
|
}
|
|
|
/*
|
/*
|
* This may be an imported command. Try to get the real
|
* This may be an imported command. Try to get the real
|
* command and see if it represents a class.
|
* command and see if it represents a class.
|
*/
|
*/
|
cmdPtr = (Command*)TclGetOriginalCommand(cmd);
|
cmdPtr = (Command*)TclGetOriginalCommand(cmd);
|
if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) {
|
if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) {
|
return 1;
|
return 1;
|
}
|
}
|
return 0;
|
return 0;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_FindClass()
|
* Itcl_FindClass()
|
*
|
*
|
* Searches for the specified class in the active namespace. If the
|
* Searches for the specified class in the active namespace. If the
|
* class is found, this procedure returns a pointer to the class
|
* class is found, this procedure returns a pointer to the class
|
* definition. Otherwise, if the autoload flag is non-zero, an
|
* definition. Otherwise, if the autoload flag is non-zero, an
|
* attempt will be made to autoload the class definition. If it
|
* attempt will be made to autoload the class definition. If it
|
* still can't be found, this procedure returns NULL, along with an
|
* still can't be found, this procedure returns NULL, along with an
|
* error message in the interpreter.
|
* error message in the interpreter.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ItclClass*
|
ItclClass*
|
Itcl_FindClass(interp, path, autoload)
|
Itcl_FindClass(interp, path, autoload)
|
Tcl_Interp* interp; /* interpreter containing class */
|
Tcl_Interp* interp; /* interpreter containing class */
|
char* path; /* path name for class */
|
char* path; /* path name for class */
|
{
|
{
|
Tcl_Namespace* classNs;
|
Tcl_Namespace* classNs;
|
|
|
/*
|
/*
|
* Search for a namespace with the specified name, and if
|
* Search for a namespace with the specified name, and if
|
* one is found, see if it is a class namespace.
|
* one is found, see if it is a class namespace.
|
*/
|
*/
|
classNs = Itcl_FindClassNamespace(interp, path);
|
classNs = Itcl_FindClassNamespace(interp, path);
|
|
|
if (classNs && Itcl_IsClassNamespace(classNs)) {
|
if (classNs && Itcl_IsClassNamespace(classNs)) {
|
return (ItclClass*)classNs->clientData;
|
return (ItclClass*)classNs->clientData;
|
}
|
}
|
|
|
/*
|
/*
|
* If the autoload flag is set, try to autoload the class
|
* If the autoload flag is set, try to autoload the class
|
* definition.
|
* definition.
|
*/
|
*/
|
if (autoload) {
|
if (autoload) {
|
if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) {
|
if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while attempting to autoload class \"%.200s\")", path);
|
sprintf(msg, "\n (while attempting to autoload class \"%.200s\")", path);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
return NULL;
|
return NULL;
|
}
|
}
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
|
|
classNs = Itcl_FindClassNamespace(interp, path);
|
classNs = Itcl_FindClassNamespace(interp, path);
|
if (classNs && Itcl_IsClassNamespace(classNs)) {
|
if (classNs && Itcl_IsClassNamespace(classNs)) {
|
return (ItclClass*)classNs->clientData;
|
return (ItclClass*)classNs->clientData;
|
}
|
}
|
}
|
}
|
|
|
Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"",
|
Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"",
|
Tcl_GetCurrentNamespace(interp)->fullName, "\"",
|
Tcl_GetCurrentNamespace(interp)->fullName, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
|
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_FindClassNamespace()
|
* Itcl_FindClassNamespace()
|
*
|
*
|
* Searches for the specified class namespace. The normal Tcl procedure
|
* Searches for the specified class namespace. The normal Tcl procedure
|
* Tcl_FindNamespace also searches for namespaces, but only in the
|
* Tcl_FindNamespace also searches for namespaces, but only in the
|
* current namespace context. This makes it hard to find one class
|
* current namespace context. This makes it hard to find one class
|
* from within another. For example, suppose. you have two namespaces
|
* 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
|
* 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
|
* Bar, you won't find it with Tcl_FindNamespace. This behavior is
|
* okay for namespaces, but wrong for classes.
|
* okay for namespaces, but wrong for classes.
|
*
|
*
|
* This procedure search for a class namespace. If the name is
|
* This procedure search for a class namespace. If the name is
|
* absolute (i.e., starts with "::"), then that one name is checked,
|
* 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,
|
* 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
|
* it is sought in the current namespace context and in the global
|
* context, just like the normal command lookup.
|
* context, just like the normal command lookup.
|
*
|
*
|
* This procedure returns a pointer to the desired namespace, or
|
* This procedure returns a pointer to the desired namespace, or
|
* NULL if the namespace was not found.
|
* NULL if the namespace was not found.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
Tcl_Namespace*
|
Tcl_Namespace*
|
Itcl_FindClassNamespace(interp, path)
|
Itcl_FindClassNamespace(interp, path)
|
Tcl_Interp* interp; /* interpreter containing class */
|
Tcl_Interp* interp; /* interpreter containing class */
|
char* path; /* path name for class */
|
char* path; /* path name for class */
|
{
|
{
|
Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp);
|
Tcl_Namespace* classNs;
|
Tcl_Namespace* classNs;
|
Tcl_DString buffer;
|
Tcl_DString buffer;
|
|
|
/*
|
/*
|
* Look up the namespace. If the name is not absolute, then
|
* Look up the namespace. If the name is not absolute, then
|
* see if it's the current namespace, and try the global
|
* see if it's the current namespace, and try the global
|
* namespace as well.
|
* namespace as well.
|
*/
|
*/
|
classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
|
classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL,
|
/* flags */ 0);
|
/* flags */ 0);
|
|
|
if ( !classNs && contextNs->parentPtr != NULL &&
|
if ( !classNs && contextNs->parentPtr != NULL &&
|
(*path != ':' || *(path+1) != ':') ) {
|
(*path != ':' || *(path+1) != ':') ) {
|
|
|
if (strcmp(contextNs->name, path) == 0) {
|
if (strcmp(contextNs->name, path) == 0) {
|
classNs = contextNs;
|
classNs = contextNs;
|
}
|
}
|
else {
|
else {
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, path, -1);
|
Tcl_DStringAppend(&buffer, path, -1);
|
|
|
classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
|
classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer),
|
(Tcl_Namespace*)NULL, /* flags */ 0);
|
(Tcl_Namespace*)NULL, /* flags */ 0);
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
}
|
}
|
}
|
}
|
return classNs;
|
return classNs;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_HandleClass()
|
* Itcl_HandleClass()
|
*
|
*
|
* Invoked by Tcl whenever the user issues the command associated with
|
* Invoked by Tcl whenever the user issues the command associated with
|
* a class name. Handles the following syntax:
|
* a class name. Handles the following syntax:
|
*
|
*
|
* <className>
|
* <className>
|
* <className> <objName> ?<args>...?
|
* <className> <objName> ?<args>...?
|
*
|
*
|
* Without any arguments, the command does nothing. In the olden days,
|
* Without any arguments, the command does nothing. In the olden days,
|
* this allowed the class name to be invoked by itself to prompt the
|
* this allowed the class name to be invoked by itself to prompt the
|
* autoloader to load the class definition. Today, this behavior is
|
* autoloader to load the class definition. Today, this behavior is
|
* retained for backward compatibility with old releases.
|
* retained for backward compatibility with old releases.
|
*
|
*
|
* If arguments are specified, then this procedure creates a new
|
* If arguments are specified, then this procedure creates a new
|
* object named <objName> in the appropriate class. Note that if
|
* object named <objName> in the appropriate class. Note that if
|
* <objName> contains "#auto", that part is automatically replaced
|
* <objName> contains "#auto", that part is automatically replaced
|
* by a unique string built from the class name.
|
* by a unique string built from the class name.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_HandleClass(clientData, interp, objc, objv)
|
Itcl_HandleClass(clientData, interp, objc, objv)
|
ClientData clientData; /* class definition */
|
ClientData clientData; /* class definition */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclClass *cdefnPtr = (ItclClass*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)clientData;
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
char unique[256]; /* buffer used for unique part of object names */
|
char unique[256]; /* buffer used for unique part of object names */
|
Tcl_DString buffer; /* buffer used to build object names */
|
Tcl_DString buffer; /* buffer used to build object names */
|
char *token, *objName, tmp, *start, *pos, *match;
|
char *token, *objName, tmp, *start, *pos, *match;
|
|
|
ItclObject *newObj;
|
ItclObject *newObj;
|
Tcl_CallFrame frame;
|
Tcl_CallFrame frame;
|
|
|
/*
|
/*
|
* If the command is invoked without an object name, then do nothing.
|
* If the command is invoked without an object name, then do nothing.
|
* This used to support autoloading--that the class name could be
|
* This used to support autoloading--that the class name could be
|
* invoked as a command by itself, prompting the autoloader to
|
* invoked as a command by itself, prompting the autoloader to
|
* load the class definition. We retain the behavior here for
|
* load the class definition. We retain the behavior here for
|
* backward-compatibility with earlier releases.
|
* backward-compatibility with earlier releases.
|
*/
|
*/
|
if (objc == 1) {
|
if (objc == 1) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If the object name is "::", and if this is an old-style class
|
* If the object name is "::", and if this is an old-style class
|
* definition, then treat the remaining arguments as a command
|
* definition, then treat the remaining arguments as a command
|
* in the class namespace. This used to be the way of invoking
|
* in the class namespace. This used to be the way of invoking
|
* a class proc, but the new syntax is "class::proc" (without
|
* a class proc, but the new syntax is "class::proc" (without
|
* spaces).
|
* spaces).
|
*/
|
*/
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) {
|
if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) {
|
if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) {
|
if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) {
|
|
|
result = Tcl_PushCallFrame(interp, &frame,
|
result = Tcl_PushCallFrame(interp, &frame,
|
cdefnPtr->namesp, /* isProcCallFrame */ 0);
|
cdefnPtr->namesp, /* isProcCallFrame */ 0);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
return result;
|
return result;
|
}
|
}
|
result = Itcl_EvalArgs(interp, objc-2, objv+2);
|
result = Itcl_EvalArgs(interp, objc-2, objv+2);
|
|
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
return result;
|
return result;
|
}
|
}
|
|
|
/*
|
/*
|
* If this is not an old-style class, then return an error
|
* If this is not an old-style class, then return an error
|
* describing the syntax change.
|
* describing the syntax change.
|
*/
|
*/
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"syntax \"class :: proc\" is an anachronism\n",
|
"syntax \"class :: proc\" is an anachronism\n",
|
"[incr Tcl] no longer supports this syntax.\n",
|
"[incr Tcl] no longer supports this syntax.\n",
|
"Instead, remove the spaces from your procedure invocations:\n",
|
"Instead, remove the spaces from your procedure invocations:\n",
|
" ",
|
" ",
|
Tcl_GetStringFromObj(objv[0], (int*)NULL), "::",
|
Tcl_GetStringFromObj(objv[0], (int*)NULL), "::",
|
Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?",
|
Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Otherwise, we have a proper object name. Create a new instance
|
* Otherwise, we have a proper object name. Create a new instance
|
* with that name. If the name contains "#auto", replace this with
|
* with that name. If the name contains "#auto", replace this with
|
* a uniquely generated string based on the class name.
|
* a uniquely generated string based on the class name.
|
*/
|
*/
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
objName = NULL;
|
objName = NULL;
|
|
|
match = "#auto";
|
match = "#auto";
|
start = token;
|
start = token;
|
for (pos=start; *pos != '\0'; pos++) {
|
for (pos=start; *pos != '\0'; pos++) {
|
if (*pos == *match) {
|
if (*pos == *match) {
|
if (*(++match) == '\0') {
|
if (*(++match) == '\0') {
|
tmp = *start;
|
tmp = *start;
|
*start = '\0'; /* null-terminate first part */
|
*start = '\0'; /* null-terminate first part */
|
|
|
/*
|
/*
|
* Substitute a unique part in for "#auto", and keep
|
* Substitute a unique part in for "#auto", and keep
|
* incrementing a counter until a valid name is found.
|
* incrementing a counter until a valid name is found.
|
*/
|
*/
|
do {
|
do {
|
sprintf(unique,"%.200s%d", cdefnPtr->name,
|
sprintf(unique,"%.200s%d", cdefnPtr->name,
|
cdefnPtr->unique++);
|
cdefnPtr->unique++);
|
unique[0] = tolower(unique[0]);
|
unique[0] = tolower(unique[0]);
|
|
|
Tcl_DStringTrunc(&buffer, 0);
|
Tcl_DStringTrunc(&buffer, 0);
|
Tcl_DStringAppend(&buffer, token, -1);
|
Tcl_DStringAppend(&buffer, token, -1);
|
Tcl_DStringAppend(&buffer, unique, -1);
|
Tcl_DStringAppend(&buffer, unique, -1);
|
Tcl_DStringAppend(&buffer, start+5, -1);
|
Tcl_DStringAppend(&buffer, start+5, -1);
|
|
|
objName = Tcl_DStringValue(&buffer);
|
objName = Tcl_DStringValue(&buffer);
|
if (Itcl_FindObject(interp, objName, &newObj) != TCL_OK) {
|
if (Itcl_FindObject(interp, objName, &newObj) != TCL_OK) {
|
break; /* if an error is found, bail out! */
|
break; /* if an error is found, bail out! */
|
}
|
}
|
} while (newObj != NULL);
|
} while (newObj != NULL);
|
|
|
*start = tmp; /* undo null-termination */
|
*start = tmp; /* undo null-termination */
|
objName = Tcl_DStringValue(&buffer);
|
objName = Tcl_DStringValue(&buffer);
|
break; /* object name is ready to go! */
|
break; /* object name is ready to go! */
|
}
|
}
|
}
|
}
|
else {
|
else {
|
match = "#auto";
|
match = "#auto";
|
pos = start++;
|
pos = start++;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* If "#auto" was not found, then just use object name as-is.
|
* If "#auto" was not found, then just use object name as-is.
|
*/
|
*/
|
if (objName == NULL) {
|
if (objName == NULL) {
|
objName = token;
|
objName = token;
|
}
|
}
|
|
|
/*
|
/*
|
* Try to create a new object. If successful, return the
|
* Try to create a new object. If successful, return the
|
* object name as the result of this command.
|
* object name as the result of this command.
|
*/
|
*/
|
result = Itcl_CreateObject(interp, objName, cdefnPtr,
|
result = Itcl_CreateObject(interp, objName, cdefnPtr,
|
objc-2, objv+2, &newObj);
|
objc-2, objv+2, &newObj);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
Tcl_SetResult(interp, objName, TCL_VOLATILE);
|
Tcl_SetResult(interp, objName, TCL_VOLATILE);
|
}
|
}
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassCmdResolver()
|
* Itcl_ClassCmdResolver()
|
*
|
*
|
* Used by the class namespaces to handle name resolution for all
|
* Used by the class namespaces to handle name resolution for all
|
* commands. This procedure looks for references to class methods
|
* commands. This procedure looks for references to class methods
|
* and procs, and returns TCL_OK along with the appropriate Tcl
|
* and procs, and returns TCL_OK along with the appropriate Tcl
|
* command in the rPtr argument. If a particular command is private,
|
* command in the rPtr argument. If a particular command is private,
|
* this procedure returns TCL_ERROR and access to the command is
|
* this procedure returns TCL_ERROR and access to the command is
|
* denied. If a command is not recognized, this procedure returns
|
* denied. If a command is not recognized, this procedure returns
|
* TCL_CONTINUE, and lookup continues via the normal Tcl name
|
* TCL_CONTINUE, and lookup continues via the normal Tcl name
|
* resolution rules.
|
* resolution rules.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassCmdResolver(interp, name, context, flags, rPtr)
|
Itcl_ClassCmdResolver(interp, name, context, flags, rPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char* name; /* name of the command being accessed */
|
char* name; /* name of the command being accessed */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
int flags; /* TCL_LEAVE_ERR_MSG => leave error messages
|
int flags; /* TCL_LEAVE_ERR_MSG => leave error messages
|
* in interp if anything goes wrong */
|
* in interp if anything goes wrong */
|
Tcl_Command *rPtr; /* returns: resolved command */
|
Tcl_Command *rPtr; /* returns: resolved command */
|
{
|
{
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
|
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Command *cmdPtr;
|
Command *cmdPtr;
|
|
|
/*
|
/*
|
* If the command is a member function, and if it is
|
* If the command is a member function, and if it is
|
* accessible, return its Tcl command handle.
|
* accessible, return its Tcl command handle.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name);
|
entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name);
|
if (!entry) {
|
if (!entry) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
|
|
|
|
/*
|
/*
|
* For protected/private functions, figure out whether or
|
* For protected/private functions, figure out whether or
|
* not the function is accessible from the current context.
|
* not the function is accessible from the current context.
|
*
|
*
|
* TRICKY NOTE: Use Itcl_GetTrueNamespace to determine
|
* TRICKY NOTE: Use Itcl_GetTrueNamespace to determine
|
* the current context. If the current call frame is
|
* the current context. If the current call frame is
|
* "transparent", this handles it properly.
|
* "transparent", this handles it properly.
|
*/
|
*/
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
context = Itcl_GetTrueNamespace(interp, cdefn->info);
|
context = Itcl_GetTrueNamespace(interp, cdefn->info);
|
|
|
if (!Itcl_CanAccessFunc(mfunc, context)) {
|
if (!Itcl_CanAccessFunc(mfunc, context)) {
|
|
|
if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
|
if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", name, "\": ",
|
"can't access \"", name, "\": ",
|
Itcl_ProtectionStr(mfunc->member->protection),
|
Itcl_ProtectionStr(mfunc->member->protection),
|
" variable",
|
" variable",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Looks like we found an accessible member function.
|
* Looks like we found an accessible member function.
|
*
|
*
|
* TRICKY NOTE: Check to make sure that the command handle
|
* TRICKY NOTE: Check to make sure that the command handle
|
* is still valid. If someone has deleted or renamed the
|
* is still valid. If someone has deleted or renamed the
|
* command, it may not be. This is just the time to catch
|
* command, it may not be. This is just the time to catch
|
* it--as it is being resolved again by the compiler.
|
* it--as it is being resolved again by the compiler.
|
*/
|
*/
|
cmdPtr = (Command*)mfunc->accessCmd;
|
cmdPtr = (Command*)mfunc->accessCmd;
|
if (!cmdPtr || cmdPtr->deleted) {
|
if (!cmdPtr || cmdPtr->deleted) {
|
mfunc->accessCmd = NULL;
|
mfunc->accessCmd = NULL;
|
|
|
if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
|
if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", name, "\": deleted or redefined\n",
|
"can't access \"", name, "\": deleted or redefined\n",
|
"(use the \"body\" command to redefine methods/procs)",
|
"(use the \"body\" command to redefine methods/procs)",
|
(char*)NULL);
|
(char*)NULL);
|
}
|
}
|
return TCL_ERROR; /* disallow access! */
|
return TCL_ERROR; /* disallow access! */
|
}
|
}
|
|
|
*rPtr = mfunc->accessCmd;
|
*rPtr = mfunc->accessCmd;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassVarResolver()
|
* Itcl_ClassVarResolver()
|
*
|
*
|
* Used by the class namespaces to handle name resolution for runtime
|
* Used by the class namespaces to handle name resolution for runtime
|
* variable accesses. This procedure looks for references to both
|
* variable accesses. This procedure looks for references to both
|
* common variables and instance variables at runtime. It is used as
|
* common variables and instance variables at runtime. It is used as
|
* a second line of defense, to handle references that could not be
|
* a second line of defense, to handle references that could not be
|
* resolved as compiled locals.
|
* resolved as compiled locals.
|
*
|
*
|
* If a variable is found, this procedure returns TCL_OK along with
|
* If a variable is found, this procedure returns TCL_OK along with
|
* the appropriate Tcl variable in the rPtr argument. If a particular
|
* the appropriate Tcl variable in the rPtr argument. If a particular
|
* variable is private, this procedure returns TCL_ERROR and access
|
* variable is private, this procedure returns TCL_ERROR and access
|
* to the variable is denied. If a variable is not recognized, this
|
* to the variable is denied. If a variable is not recognized, this
|
* procedure returns TCL_CONTINUE, and lookup continues via the normal
|
* procedure returns TCL_CONTINUE, and lookup continues via the normal
|
* Tcl name resolution rules.
|
* Tcl name resolution rules.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassVarResolver(interp, name, context, flags, rPtr)
|
Itcl_ClassVarResolver(interp, name, context, flags, rPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char* name; /* name of the variable being accessed */
|
char* name; /* name of the variable being accessed */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
int flags; /* TCL_LEAVE_ERR_MSG => leave error messages
|
int flags; /* TCL_LEAVE_ERR_MSG => leave error messages
|
* in interp if anything goes wrong */
|
* in interp if anything goes wrong */
|
Tcl_Var *rPtr; /* returns: resolved variable */
|
Tcl_Var *rPtr; /* returns: resolved variable */
|
{
|
{
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
Tcl_CallFrame *framePtr;
|
Tcl_CallFrame *framePtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
|
|
assert(Itcl_IsClassNamespace(context));
|
assert(Itcl_IsClassNamespace(context));
|
|
|
/*
|
/*
|
* If this is a global variable, handle it in the usual
|
* If this is a global variable, handle it in the usual
|
* Tcl manner.
|
* Tcl manner.
|
*/
|
*/
|
if (flags & TCL_GLOBAL_ONLY) {
|
if (flags & TCL_GLOBAL_ONLY) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
/*
|
/*
|
* See if the variable is a known data member and accessible.
|
* See if the variable is a known data member and accessible.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, name);
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, name);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (!vlookup->accessible) {
|
if (!vlookup->accessible) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
/*
|
/*
|
* If this is a common data member, then its variable
|
* If this is a common data member, then its variable
|
* is easy to find. Return it directly.
|
* is easy to find. Return it directly.
|
*/
|
*/
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
*rPtr = vlookup->var.common;
|
*rPtr = vlookup->var.common;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If this is an instance variable, then we have to
|
* If this is an instance variable, then we have to
|
* find the object context, then index into its data
|
* find the object context, then index into its data
|
* array to get the actual variable.
|
* array to get the actual variable.
|
*/
|
*/
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
|
|
entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
|
entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
|
if (entry == NULL) {
|
if (entry == NULL) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
|
|
/*
|
/*
|
* TRICKY NOTE: We've resolved the variable in the current
|
* TRICKY NOTE: We've resolved the variable in the current
|
* class context, but we must also be careful to get its
|
* class context, but we must also be careful to get its
|
* index from the most-specific class context. Variables
|
* index from the most-specific class context. Variables
|
* are arranged differently depending on which class
|
* are arranged differently depending on which class
|
* constructed the object.
|
* constructed the object.
|
*/
|
*/
|
if (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
|
if (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
vlookup->vdefn->member->fullname);
|
vlookup->vdefn->member->fullname);
|
|
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
}
|
}
|
}
|
}
|
*rPtr = (Tcl_Var)contextObj->data[vlookup->var.index];
|
*rPtr = (Tcl_Var)contextObj->data[vlookup->var.index];
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_ClassCompiledVarResolver()
|
* Itcl_ClassCompiledVarResolver()
|
*
|
*
|
* Used by the class namespaces to handle name resolution for compile
|
* Used by the class namespaces to handle name resolution for compile
|
* time variable accesses. This procedure looks for references to
|
* time variable accesses. This procedure looks for references to
|
* both common variables and instance variables at compile time. If
|
* both common variables and instance variables at compile time. If
|
* the variables are found, they are characterized in a generic way
|
* the variables are found, they are characterized in a generic way
|
* by their ItclVarLookup record. At runtime, Tcl constructs the
|
* by their ItclVarLookup record. At runtime, Tcl constructs the
|
* compiled local variables by calling ItclClassRuntimeVarResolver.
|
* compiled local variables by calling ItclClassRuntimeVarResolver.
|
*
|
*
|
* If a variable is found, this procedure returns TCL_OK along with
|
* If a variable is found, this procedure returns TCL_OK along with
|
* information about the variable in the rPtr argument. If a particular
|
* information about the variable in the rPtr argument. If a particular
|
* variable is private, this procedure returns TCL_ERROR and access
|
* variable is private, this procedure returns TCL_ERROR and access
|
* to the variable is denied. If a variable is not recognized, this
|
* to the variable is denied. If a variable is not recognized, this
|
* procedure returns TCL_CONTINUE, and lookup continues via the normal
|
* procedure returns TCL_CONTINUE, and lookup continues via the normal
|
* Tcl name resolution rules.
|
* Tcl name resolution rules.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_ClassCompiledVarResolver(interp, name, length, context, rPtr)
|
Itcl_ClassCompiledVarResolver(interp, name, length, context, rPtr)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char* name; /* name of the variable being accessed */
|
char* name; /* name of the variable being accessed */
|
int length; /* number of characters in name */
|
int length; /* number of characters in name */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
Tcl_Namespace *context; /* namespace performing the resolution */
|
Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to
|
Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to
|
* resolve the variable at runtime */
|
* resolve the variable at runtime */
|
{
|
{
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
ItclClass *cdefn = (ItclClass*)context->clientData;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
char *buffer, storage[64];
|
char *buffer, storage[64];
|
|
|
assert(Itcl_IsClassNamespace(context));
|
assert(Itcl_IsClassNamespace(context));
|
|
|
/*
|
/*
|
* Copy the name to local storage so we can NULL terminate it.
|
* Copy the name to local storage so we can NULL terminate it.
|
* If the name is long, allocate extra space for it.
|
* If the name is long, allocate extra space for it.
|
*/
|
*/
|
if (length < sizeof(storage)) {
|
if (length < sizeof(storage)) {
|
buffer = storage;
|
buffer = storage;
|
} else {
|
} else {
|
buffer = (char*)ckalloc((unsigned)(length+1));
|
buffer = (char*)ckalloc((unsigned)(length+1));
|
}
|
}
|
memcpy((void*)buffer, (void*)name, (size_t)length);
|
memcpy((void*)buffer, (void*)name, (size_t)length);
|
buffer[length] = '\0';
|
buffer[length] = '\0';
|
|
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, buffer);
|
entry = Tcl_FindHashEntry(&cdefn->resolveVars, buffer);
|
|
|
if (buffer != storage) {
|
if (buffer != storage) {
|
ckfree(buffer);
|
ckfree(buffer);
|
}
|
}
|
|
|
/*
|
/*
|
* If the name is not found, or if it is inaccessible,
|
* If the name is not found, or if it is inaccessible,
|
* continue on with the normal Tcl name resolution rules.
|
* continue on with the normal Tcl name resolution rules.
|
*/
|
*/
|
if (entry == NULL) {
|
if (entry == NULL) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (!vlookup->accessible) {
|
if (!vlookup->accessible) {
|
return TCL_CONTINUE;
|
return TCL_CONTINUE;
|
}
|
}
|
|
|
/*
|
/*
|
* Return the ItclVarLookup record. At runtime, Tcl will
|
* Return the ItclVarLookup record. At runtime, Tcl will
|
* call ItclClassRuntimeVarResolver with this record, to
|
* call ItclClassRuntimeVarResolver with this record, to
|
* plug in the appropriate variable for the current object
|
* plug in the appropriate variable for the current object
|
* context.
|
* context.
|
*/
|
*/
|
(*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo));
|
(*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo));
|
(*rPtr)->fetchProc = ItclClassRuntimeVarResolver;
|
(*rPtr)->fetchProc = ItclClassRuntimeVarResolver;
|
(*rPtr)->deleteProc = NULL;
|
(*rPtr)->deleteProc = NULL;
|
((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup;
|
((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup;
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclClassRuntimeVarResolver()
|
* ItclClassRuntimeVarResolver()
|
*
|
*
|
* Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc
|
* Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc
|
* at runtime. Resolves data members identified earlier by
|
* at runtime. Resolves data members identified earlier by
|
* Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation
|
* Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation
|
* for the data member.
|
* for the data member.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static Tcl_Var
|
static Tcl_Var
|
ItclClassRuntimeVarResolver(interp, resVarInfo)
|
ItclClassRuntimeVarResolver(interp, resVarInfo)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_ResolvedVarInfo *resVarInfo; /* contains ItclVarLookup rep
|
Tcl_ResolvedVarInfo *resVarInfo; /* contains ItclVarLookup rep
|
* for variable */
|
* for variable */
|
{
|
{
|
ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup;
|
ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup;
|
|
|
Tcl_CallFrame *framePtr;
|
Tcl_CallFrame *framePtr;
|
ItclClass *cdefn;
|
ItclClass *cdefn;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* If this is a common data member, then the associated
|
* If this is a common data member, then the associated
|
* variable is known directly.
|
* variable is known directly.
|
*/
|
*/
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
|
return vlookup->var.common;
|
return vlookup->var.common;
|
}
|
}
|
cdefn = vlookup->vdefn->member->classDefn;
|
cdefn = vlookup->vdefn->member->classDefn;
|
|
|
/*
|
/*
|
* Otherwise, get the current object context and find the
|
* Otherwise, get the current object context and find the
|
* variable in its data table.
|
* variable in its data table.
|
*
|
*
|
* TRICKY NOTE: Get the index for this variable using the
|
* TRICKY NOTE: Get the index for this variable using the
|
* virtual table for the MOST-SPECIFIC class.
|
* virtual table for the MOST-SPECIFIC class.
|
*/
|
*/
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
framePtr = _Tcl_GetCallFrame(interp, 0);
|
|
|
entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
|
entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
|
if (entry) {
|
if (entry) {
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
contextObj = (ItclObject*)Tcl_GetHashValue(entry);
|
|
|
if (contextObj != NULL) {
|
if (contextObj != NULL) {
|
if (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
|
if (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
|
vlookup->vdefn->member->fullname);
|
vlookup->vdefn->member->fullname);
|
|
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
}
|
}
|
}
|
}
|
return (Tcl_Var)contextObj->data[vlookup->var.index];
|
return (Tcl_Var)contextObj->data[vlookup->var.index];
|
}
|
}
|
}
|
}
|
return NULL;
|
return NULL;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_BuildVirtualTables()
|
* Itcl_BuildVirtualTables()
|
*
|
*
|
* Invoked whenever the class heritage changes or members are added or
|
* Invoked whenever the class heritage changes or members are added or
|
* removed from a class definition to rebuild the member lookup
|
* removed from a class definition to rebuild the member lookup
|
* tables. There are two tables:
|
* tables. There are two tables:
|
*
|
*
|
* METHODS: resolveCmds
|
* METHODS: resolveCmds
|
* Used primarily in Itcl_ClassCmdResolver() to resolve all
|
* Used primarily in Itcl_ClassCmdResolver() to resolve all
|
* command references in a namespace.
|
* command references in a namespace.
|
*
|
*
|
* DATA MEMBERS: resolveVars
|
* DATA MEMBERS: resolveVars
|
* Used primarily in Itcl_ClassVarResolver() to quickly resolve
|
* Used primarily in Itcl_ClassVarResolver() to quickly resolve
|
* variable references in each class scope.
|
* variable references in each class scope.
|
*
|
*
|
* These tables store every possible name for each command/variable
|
* These tables store every possible name for each command/variable
|
* (member, class::member, namesp::class::member, etc.). Members
|
* (member, class::member, namesp::class::member, etc.). Members
|
* in a derived class may shadow members with the same name in a
|
* in a derived class may shadow members with the same name in a
|
* base class. In that case, the simple name in the resolution
|
* base class. In that case, the simple name in the resolution
|
* table will point to the most-specific member.
|
* table will point to the most-specific member.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_BuildVirtualTables(cdefnPtr)
|
Itcl_BuildVirtualTables(cdefnPtr)
|
ItclClass* cdefnPtr; /* class definition being updated */
|
ItclClass* cdefnPtr; /* class definition being updated */
|
{
|
{
|
Tcl_HashEntry *entry, *hPtr;
|
Tcl_HashEntry *entry, *hPtr;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
Namespace* nsPtr;
|
Namespace* nsPtr;
|
Tcl_DString buffer, buffer2;
|
Tcl_DString buffer, buffer2;
|
int newEntry;
|
int newEntry;
|
|
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer);
|
Tcl_DStringInit(&buffer2);
|
Tcl_DStringInit(&buffer2);
|
|
|
/*
|
/*
|
* Clear the variable resolution table.
|
* Clear the variable resolution table.
|
*/
|
*/
|
entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
|
entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
|
while (entry) {
|
while (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (--vlookup->usage == 0) {
|
if (--vlookup->usage == 0) {
|
ckfree((char*)vlookup);
|
ckfree((char*)vlookup);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
Tcl_DeleteHashTable(&cdefnPtr->resolveVars);
|
Tcl_DeleteHashTable(&cdefnPtr->resolveVars);
|
Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS);
|
cdefnPtr->numInstanceVars = 0;
|
cdefnPtr->numInstanceVars = 0;
|
|
|
/*
|
/*
|
* Set aside the first object-specific slot for the built-in
|
* Set aside the first object-specific slot for the built-in
|
* "this" variable. Only allocate one of these, even though
|
* "this" variable. Only allocate one of these, even though
|
* there is a definition for "this" in each class scope.
|
* there is a definition for "this" in each class scope.
|
*/
|
*/
|
cdefnPtr->numInstanceVars++;
|
cdefnPtr->numInstanceVars++;
|
|
|
/*
|
/*
|
* Scan through all classes in the hierarchy, from most to
|
* Scan through all classes in the hierarchy, from most to
|
* least specific. Add a lookup entry for each variable
|
* least specific. Add a lookup entry for each variable
|
* into the table.
|
* into the table.
|
*/
|
*/
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
|
|
vlookup = (ItclVarLookup*)ckalloc(sizeof(ItclVarLookup));
|
vlookup = (ItclVarLookup*)ckalloc(sizeof(ItclVarLookup));
|
vlookup->vdefn = vdefn;
|
vlookup->vdefn = vdefn;
|
vlookup->usage = 0;
|
vlookup->usage = 0;
|
vlookup->leastQualName = NULL;
|
vlookup->leastQualName = NULL;
|
|
|
/*
|
/*
|
* If this variable is PRIVATE to another class scope,
|
* If this variable is PRIVATE to another class scope,
|
* then mark it as "inaccessible".
|
* then mark it as "inaccessible".
|
*/
|
*/
|
vlookup->accessible =
|
vlookup->accessible =
|
( vdefn->member->protection != ITCL_PRIVATE ||
|
( vdefn->member->protection != ITCL_PRIVATE ||
|
vdefn->member->classDefn == cdefnPtr );
|
vdefn->member->classDefn == cdefnPtr );
|
|
|
/*
|
/*
|
* If this is a common variable, then keep a reference to
|
* If this is a common variable, then keep a reference to
|
* the variable directly. Otherwise, keep an index into
|
* the variable directly. Otherwise, keep an index into
|
* the object's variable table.
|
* the object's variable table.
|
*/
|
*/
|
if ((vdefn->member->flags & ITCL_COMMON) != 0) {
|
if ((vdefn->member->flags & ITCL_COMMON) != 0) {
|
nsPtr = (Namespace*)cdPtr->namesp;
|
nsPtr = (Namespace*)cdPtr->namesp;
|
hPtr = Tcl_FindHashEntry(&nsPtr->varTable, vdefn->member->name);
|
hPtr = Tcl_FindHashEntry(&nsPtr->varTable, vdefn->member->name);
|
assert(hPtr != NULL);
|
assert(hPtr != NULL);
|
|
|
vlookup->var.common = (Tcl_Var)Tcl_GetHashValue(hPtr);
|
vlookup->var.common = (Tcl_Var)Tcl_GetHashValue(hPtr);
|
}
|
}
|
else {
|
else {
|
/*
|
/*
|
* If this is a reference to the built-in "this"
|
* If this is a reference to the built-in "this"
|
* variable, then its index is "0". Otherwise,
|
* variable, then its index is "0". Otherwise,
|
* add another slot to the end of the table.
|
* add another slot to the end of the table.
|
*/
|
*/
|
if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
|
if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
|
vlookup->var.index = 0;
|
vlookup->var.index = 0;
|
}
|
}
|
else {
|
else {
|
vlookup->var.index = cdefnPtr->numInstanceVars++;
|
vlookup->var.index = cdefnPtr->numInstanceVars++;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Create all possible names for this variable and enter
|
* Create all possible names for this variable and enter
|
* them into the variable resolution table:
|
* them into the variable resolution table:
|
* var
|
* var
|
* class::var
|
* class::var
|
* namesp1::class::var
|
* namesp1::class::var
|
* namesp2::namesp1::class::var
|
* namesp2::namesp1::class::var
|
* ...
|
* ...
|
*/
|
*/
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, vdefn->member->name, -1);
|
Tcl_DStringAppend(&buffer, vdefn->member->name, -1);
|
nsPtr = (Namespace*)cdPtr->namesp;
|
nsPtr = (Namespace*)cdPtr->namesp;
|
|
|
while (1) {
|
while (1) {
|
entry = Tcl_CreateHashEntry(&cdefnPtr->resolveVars,
|
entry = Tcl_CreateHashEntry(&cdefnPtr->resolveVars,
|
Tcl_DStringValue(&buffer), &newEntry);
|
Tcl_DStringValue(&buffer), &newEntry);
|
|
|
if (newEntry) {
|
if (newEntry) {
|
Tcl_SetHashValue(entry, (ClientData)vlookup);
|
Tcl_SetHashValue(entry, (ClientData)vlookup);
|
vlookup->usage++;
|
vlookup->usage++;
|
|
|
if (!vlookup->leastQualName) {
|
if (!vlookup->leastQualName) {
|
vlookup->leastQualName =
|
vlookup->leastQualName =
|
Tcl_GetHashKey(&cdefnPtr->resolveVars, entry);
|
Tcl_GetHashKey(&cdefnPtr->resolveVars, entry);
|
}
|
}
|
}
|
}
|
|
|
if (nsPtr == NULL) {
|
if (nsPtr == NULL) {
|
break;
|
break;
|
}
|
}
|
Tcl_DStringSetLength(&buffer2, 0);
|
Tcl_DStringSetLength(&buffer2, 0);
|
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);
|
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, nsPtr->name, -1);
|
Tcl_DStringAppend(&buffer, nsPtr->name, -1);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1);
|
Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1);
|
|
|
nsPtr = nsPtr->parentPtr;
|
nsPtr = nsPtr->parentPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If this record is not needed, free it now.
|
* If this record is not needed, free it now.
|
*/
|
*/
|
if (vlookup->usage == 0) {
|
if (vlookup->usage == 0) {
|
ckfree((char*)vlookup);
|
ckfree((char*)vlookup);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
/*
|
/*
|
* Clear the command resolution table.
|
* Clear the command resolution table.
|
*/
|
*/
|
Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);
|
Tcl_DeleteHashTable(&cdefnPtr->resolveCmds);
|
Tcl_InitHashTable(&cdefnPtr->resolveCmds, TCL_STRING_KEYS);
|
Tcl_InitHashTable(&cdefnPtr->resolveCmds, TCL_STRING_KEYS);
|
|
|
/*
|
/*
|
* Scan through all classes in the hierarchy, from most to
|
* Scan through all classes in the hierarchy, from most to
|
* least specific. Look for the first (most-specific) definition
|
* least specific. Look for the first (most-specific) definition
|
* of each member function, and enter it into the table.
|
* of each member function, and enter it into the table.
|
*/
|
*/
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
Itcl_InitHierIter(&hier, cdefnPtr);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->functions, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->functions, &place);
|
while (entry) {
|
while (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
|
|
/*
|
/*
|
* Create all possible names for this function and enter
|
* Create all possible names for this function and enter
|
* them into the command resolution table:
|
* them into the command resolution table:
|
* func
|
* func
|
* class::func
|
* class::func
|
* namesp1::class::func
|
* namesp1::class::func
|
* namesp2::namesp1::class::func
|
* namesp2::namesp1::class::func
|
* ...
|
* ...
|
*/
|
*/
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, mfunc->member->name, -1);
|
Tcl_DStringAppend(&buffer, mfunc->member->name, -1);
|
nsPtr = (Namespace*)cdPtr->namesp;
|
nsPtr = (Namespace*)cdPtr->namesp;
|
|
|
while (1) {
|
while (1) {
|
entry = Tcl_CreateHashEntry(&cdefnPtr->resolveCmds,
|
entry = Tcl_CreateHashEntry(&cdefnPtr->resolveCmds,
|
Tcl_DStringValue(&buffer), &newEntry);
|
Tcl_DStringValue(&buffer), &newEntry);
|
|
|
if (newEntry) {
|
if (newEntry) {
|
Tcl_SetHashValue(entry, (ClientData)mfunc);
|
Tcl_SetHashValue(entry, (ClientData)mfunc);
|
}
|
}
|
|
|
if (nsPtr == NULL) {
|
if (nsPtr == NULL) {
|
break;
|
break;
|
}
|
}
|
Tcl_DStringSetLength(&buffer2, 0);
|
Tcl_DStringSetLength(&buffer2, 0);
|
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);
|
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringSetLength(&buffer, 0);
|
Tcl_DStringAppend(&buffer, nsPtr->name, -1);
|
Tcl_DStringAppend(&buffer, nsPtr->name, -1);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, "::", -1);
|
Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1);
|
Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1);
|
|
|
nsPtr = nsPtr->parentPtr;
|
nsPtr = nsPtr->parentPtr;
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer);
|
Tcl_DStringFree(&buffer2);
|
Tcl_DStringFree(&buffer2);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateVarDefn()
|
* Itcl_CreateVarDefn()
|
*
|
*
|
* Creates a new class variable definition. If this is a public
|
* Creates a new class variable definition. If this is a public
|
* variable, it may have a bit of "config" code that is used to
|
* variable, it may have a bit of "config" code that is used to
|
* update the object whenever the variable is modified via the
|
* update the object whenever the variable is modified via the
|
* built-in "configure" method.
|
* built-in "configure" method.
|
*
|
*
|
* Returns TCL_ERROR along with an error message in the specified
|
* Returns TCL_ERROR along with an error message in the specified
|
* interpreter if anything goes wrong. Otherwise, this returns
|
* interpreter if anything goes wrong. Otherwise, this returns
|
* TCL_OK and a pointer to the new variable definition in "vdefnPtr".
|
* TCL_OK and a pointer to the new variable definition in "vdefnPtr".
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_CreateVarDefn(interp, cdefn, name, init, config, vdefnPtr)
|
Itcl_CreateVarDefn(interp, cdefn, name, init, config, vdefnPtr)
|
Tcl_Interp *interp; /* interpreter managing this transaction */
|
Tcl_Interp *interp; /* interpreter managing this transaction */
|
ItclClass* cdefn; /* class containing this variable */
|
ItclClass* cdefn; /* class containing this variable */
|
char* name; /* variable name */
|
char* name; /* variable name */
|
char* init; /* initial value */
|
char* init; /* initial value */
|
char* config; /* code invoked when variable is configured */
|
char* config; /* code invoked when variable is configured */
|
ItclVarDefn** vdefnPtr; /* returns: new variable definition */
|
ItclVarDefn** vdefnPtr; /* returns: new variable definition */
|
{
|
{
|
int newEntry;
|
int newEntry;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Add this variable to the variable table for the class.
|
* Add this variable to the variable table for the class.
|
* Make sure that the variable name does not already exist.
|
* Make sure that the variable name does not already exist.
|
*/
|
*/
|
entry = Tcl_CreateHashEntry(&cdefn->variables, name, &newEntry);
|
entry = Tcl_CreateHashEntry(&cdefn->variables, name, &newEntry);
|
if (!newEntry) {
|
if (!newEntry) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"variable name \"", name, "\" already defined in class \"",
|
"variable name \"", name, "\" already defined in class \"",
|
cdefn->fullname, "\"",
|
cdefn->fullname, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If this variable has some "config" code, try to capture
|
* If this variable has some "config" code, try to capture
|
* its implementation.
|
* its implementation.
|
*/
|
*/
|
if (config) {
|
if (config) {
|
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config,
|
if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config,
|
&mcode) != TCL_OK) {
|
&mcode) != TCL_OK) {
|
|
|
Tcl_DeleteHashEntry(entry);
|
Tcl_DeleteHashEntry(entry);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_PreserveData((ClientData)mcode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);
|
}
|
}
|
else {
|
else {
|
mcode = NULL;
|
mcode = NULL;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* If everything looks good, create the variable definition.
|
* If everything looks good, create the variable definition.
|
*/
|
*/
|
vdefn = (ItclVarDefn*)ckalloc(sizeof(ItclVarDefn));
|
vdefn = (ItclVarDefn*)ckalloc(sizeof(ItclVarDefn));
|
vdefn->member = Itcl_CreateMember(interp, cdefn, name);
|
vdefn->member = Itcl_CreateMember(interp, cdefn, name);
|
vdefn->member->code = mcode;
|
vdefn->member->code = mcode;
|
|
|
if (vdefn->member->protection == ITCL_DEFAULT_PROTECT) {
|
if (vdefn->member->protection == ITCL_DEFAULT_PROTECT) {
|
vdefn->member->protection = ITCL_PROTECTED;
|
vdefn->member->protection = ITCL_PROTECTED;
|
}
|
}
|
|
|
if (init) {
|
if (init) {
|
vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1));
|
vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1));
|
strcpy(vdefn->init, init);
|
strcpy(vdefn->init, init);
|
}
|
}
|
else {
|
else {
|
vdefn->init = NULL;
|
vdefn->init = NULL;
|
}
|
}
|
|
|
Tcl_SetHashValue(entry, (ClientData)vdefn);
|
Tcl_SetHashValue(entry, (ClientData)vdefn);
|
|
|
*vdefnPtr = vdefn;
|
*vdefnPtr = vdefn;
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteVarDefn()
|
* Itcl_DeleteVarDefn()
|
*
|
*
|
* Destroys a variable definition created by Itcl_CreateVarDefn(),
|
* Destroys a variable definition created by Itcl_CreateVarDefn(),
|
* freeing all resources associated with it.
|
* freeing all resources associated with it.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteVarDefn(vdefn)
|
Itcl_DeleteVarDefn(vdefn)
|
ItclVarDefn *vdefn; /* variable definition to be destroyed */
|
ItclVarDefn *vdefn; /* variable definition to be destroyed */
|
{
|
{
|
Itcl_DeleteMember(vdefn->member);
|
Itcl_DeleteMember(vdefn->member);
|
|
|
if (vdefn->init) {
|
if (vdefn->init) {
|
ckfree(vdefn->init);
|
ckfree(vdefn->init);
|
}
|
}
|
ckfree((char*)vdefn);
|
ckfree((char*)vdefn);
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_GetCommonVar()
|
* Itcl_GetCommonVar()
|
*
|
*
|
* Returns the current value for a common class variable. The member
|
* Returns the current value for a common class variable. The member
|
* name is interpreted with respect to the given class scope. That
|
* name is interpreted with respect to the given class scope. That
|
* scope is installed as the current context before querying the
|
* scope is installed as the current context before querying the
|
* variable. This by-passes the protection level in case the variable
|
* variable. This by-passes the protection level in case the variable
|
* is "private".
|
* is "private".
|
*
|
*
|
* If successful, this procedure returns a pointer to a string value
|
* If successful, this procedure returns a pointer to a string value
|
* which remains alive until the variable changes it value. If
|
* which remains alive until the variable changes it value. If
|
* anything goes wrong, this returns NULL.
|
* anything goes wrong, this returns NULL.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
char*
|
char*
|
Itcl_GetCommonVar(interp, name, contextClass)
|
Itcl_GetCommonVar(interp, name, contextClass)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
char *name; /* name of desired instance variable */
|
char *name; /* name of desired instance variable */
|
ItclClass *contextClass; /* name is interpreted in this scope */
|
ItclClass *contextClass; /* name is interpreted in this scope */
|
{
|
{
|
char *val = NULL;
|
char *val = NULL;
|
int result;
|
int result;
|
Tcl_CallFrame frame;
|
Tcl_CallFrame frame;
|
|
|
/*
|
/*
|
* Activate the namespace for the given class. That installs
|
* Activate the namespace for the given class. That installs
|
* the appropriate name resolution rules and by-passes any
|
* the appropriate name resolution rules and by-passes any
|
* security restrictions.
|
* security restrictions.
|
*/
|
*/
|
result = Tcl_PushCallFrame(interp, &frame,
|
result = Tcl_PushCallFrame(interp, &frame,
|
contextClass->namesp, /*isProcCallFrame*/ 0);
|
contextClass->namesp, /*isProcCallFrame*/ 0);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
val = Tcl_GetVar2(interp, name, (char*)NULL, 0);
|
val = Tcl_GetVar2(interp, name, (char*)NULL, 0);
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
}
|
}
|
return val;
|
return val;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_CreateMember()
|
* Itcl_CreateMember()
|
*
|
*
|
* Creates the data record representing a class member. This is the
|
* Creates the data record representing a class member. This is the
|
* generic representation for a data member or member function.
|
* generic representation for a data member or member function.
|
* Returns a pointer to the new representation.
|
* Returns a pointer to the new representation.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ItclMember*
|
ItclMember*
|
Itcl_CreateMember(interp, cdefn, name)
|
Itcl_CreateMember(interp, cdefn, name)
|
Tcl_Interp* interp; /* interpreter managing this action */
|
Tcl_Interp* interp; /* interpreter managing this action */
|
ItclClass *cdefn; /* class definition */
|
ItclClass *cdefn; /* class definition */
|
char* name; /* name of new member */
|
char* name; /* name of new member */
|
{
|
{
|
ItclMember *memPtr;
|
ItclMember *memPtr;
|
int fullsize;
|
int fullsize;
|
|
|
/*
|
/*
|
* Allocate the memory for a class member and fill in values.
|
* Allocate the memory for a class member and fill in values.
|
*/
|
*/
|
memPtr = (ItclMember*)ckalloc(sizeof(ItclMember));
|
memPtr = (ItclMember*)ckalloc(sizeof(ItclMember));
|
memPtr->interp = interp;
|
memPtr->interp = interp;
|
memPtr->classDefn = cdefn;
|
memPtr->classDefn = cdefn;
|
memPtr->flags = 0;
|
memPtr->flags = 0;
|
memPtr->protection = Itcl_Protection(interp, 0);
|
memPtr->protection = Itcl_Protection(interp, 0);
|
memPtr->code = NULL;
|
memPtr->code = NULL;
|
|
|
fullsize = strlen(cdefn->fullname) + strlen(name) + 2;
|
fullsize = strlen(cdefn->fullname) + strlen(name) + 2;
|
memPtr->fullname = (char*)ckalloc((unsigned)(fullsize+1));
|
memPtr->fullname = (char*)ckalloc((unsigned)(fullsize+1));
|
strcpy(memPtr->fullname, cdefn->fullname);
|
strcpy(memPtr->fullname, cdefn->fullname);
|
strcat(memPtr->fullname, "::");
|
strcat(memPtr->fullname, "::");
|
strcat(memPtr->fullname, name);
|
strcat(memPtr->fullname, name);
|
|
|
memPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
|
memPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1));
|
strcpy(memPtr->name, name);
|
strcpy(memPtr->name, name);
|
|
|
return memPtr;
|
return memPtr;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteMember()
|
* Itcl_DeleteMember()
|
*
|
*
|
* Destroys all data associated with the given member function definition.
|
* Destroys all data associated with the given member function definition.
|
* Usually invoked by the interpreter when a member function is deleted.
|
* Usually invoked by the interpreter when a member function is deleted.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteMember(memPtr)
|
Itcl_DeleteMember(memPtr)
|
ItclMember *memPtr; /* pointer to member function definition */
|
ItclMember *memPtr; /* pointer to member function definition */
|
{
|
{
|
if (memPtr) {
|
if (memPtr) {
|
ckfree(memPtr->name);
|
ckfree(memPtr->name);
|
ckfree(memPtr->fullname);
|
ckfree(memPtr->fullname);
|
|
|
if (memPtr->code) {
|
if (memPtr->code) {
|
Itcl_ReleaseData((ClientData)memPtr->code);
|
Itcl_ReleaseData((ClientData)memPtr->code);
|
}
|
}
|
memPtr->code = NULL;
|
memPtr->code = NULL;
|
|
|
ckfree((char*)memPtr);
|
ckfree((char*)memPtr);
|
}
|
}
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InitHierIter()
|
* Itcl_InitHierIter()
|
*
|
*
|
* Initializes an iterator for traversing the hierarchy of the given
|
* Initializes an iterator for traversing the hierarchy of the given
|
* class. Subsequent calls to Itcl_AdvanceHierIter() will return
|
* class. Subsequent calls to Itcl_AdvanceHierIter() will return
|
* the base classes in order from most-to-least specific.
|
* the base classes in order from most-to-least specific.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_InitHierIter(iter,cdefn)
|
Itcl_InitHierIter(iter,cdefn)
|
ItclHierIter *iter; /* iterator used for traversal */
|
ItclHierIter *iter; /* iterator used for traversal */
|
ItclClass *cdefn; /* class definition for start of traversal */
|
ItclClass *cdefn; /* class definition for start of traversal */
|
{
|
{
|
Itcl_InitStack(&iter->stack);
|
Itcl_InitStack(&iter->stack);
|
Itcl_PushStack((ClientData)cdefn, &iter->stack);
|
Itcl_PushStack((ClientData)cdefn, &iter->stack);
|
iter->current = cdefn;
|
iter->current = cdefn;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_DeleteHierIter()
|
* Itcl_DeleteHierIter()
|
*
|
*
|
* Destroys an iterator for traversing class hierarchies, freeing
|
* Destroys an iterator for traversing class hierarchies, freeing
|
* all memory associated with it.
|
* all memory associated with it.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
void
|
void
|
Itcl_DeleteHierIter(iter)
|
Itcl_DeleteHierIter(iter)
|
ItclHierIter *iter; /* iterator used for traversal */
|
ItclHierIter *iter; /* iterator used for traversal */
|
{
|
{
|
Itcl_DeleteStack(&iter->stack);
|
Itcl_DeleteStack(&iter->stack);
|
iter->current = NULL;
|
iter->current = NULL;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_AdvanceHierIter()
|
* Itcl_AdvanceHierIter()
|
*
|
*
|
* Moves a class hierarchy iterator forward to the next base class.
|
* Moves a class hierarchy iterator forward to the next base class.
|
* Returns a pointer to the current class definition, or NULL when
|
* Returns a pointer to the current class definition, or NULL when
|
* the end of the hierarchy has been reached.
|
* the end of the hierarchy has been reached.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
ItclClass*
|
ItclClass*
|
Itcl_AdvanceHierIter(iter)
|
Itcl_AdvanceHierIter(iter)
|
ItclHierIter *iter; /* iterator used for traversal */
|
ItclHierIter *iter; /* iterator used for traversal */
|
{
|
{
|
register Itcl_ListElem *elem;
|
register Itcl_ListElem *elem;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
|
|
iter->current = (ItclClass*)Itcl_PopStack(&iter->stack);
|
iter->current = (ItclClass*)Itcl_PopStack(&iter->stack);
|
|
|
/*
|
/*
|
* Push classes onto the stack in reverse order, so that
|
* Push classes onto the stack in reverse order, so that
|
* they will be popped off in the proper order.
|
* they will be popped off in the proper order.
|
*/
|
*/
|
if (iter->current) {
|
if (iter->current) {
|
cdPtr = (ItclClass*)iter->current;
|
cdPtr = (ItclClass*)iter->current;
|
elem = Itcl_LastListElem(&cdPtr->bases);
|
elem = Itcl_LastListElem(&cdPtr->bases);
|
while (elem) {
|
while (elem) {
|
Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack);
|
Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack);
|
elem = Itcl_PrevListElem(elem);
|
elem = Itcl_PrevListElem(elem);
|
}
|
}
|
}
|
}
|
return iter->current;
|
return iter->current;
|
}
|
}
|
|
|