/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * These procedures handle command and variable resolution * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * RCS: $Id: itclResolve.c,v 1.1.2.21 2008/11/13 19:58:33 wiede Exp $ * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" #ifdef NOTDEF struct Tcl_ResolvedVarInfo; typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp, struct Tcl_ResolvedVarInfo *vinfoPtr); typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); /* * The following structure encapsulates the routines needed to resolve a * variable reference at runtime. Any variable specific state will typically * be appended to this structure. */ typedef struct Tcl_ResolvedVarInfo { Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp *interp, const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); typedef int (Tcl_ResolveVarProc) (Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); typedef int (Tcl_ResolveCmdProc) (Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; /* Procedure handling variable name resolution * for variables that can only be handled at * runtime. */ Tcl_ResolveCompiledVarProc *compiledVarResProc; /* Procedure handling variable name resolution * at compile time. */ } Tcl_ResolverInfo; #endif /* * This structure is a subclass of Tcl_ResolvedVarInfo that contains the * ItclVarLookup info needed at runtime. */ typedef struct ItclResolvedVarInfo { Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ ItclVarLookup *vlookup; /* Pointer to lookup info. */ } ItclResolvedVarInfo; static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr)); /* * ------------------------------------------------------------------------ * Itcl_ClassCmdResolver() * * Used by the class namespaces to handle name resolution for all * commands. This procedure looks for references to class methods * and procs, and returns TCL_OK along with the appropriate Tcl * command in the rPtr argument. If a particular command is private, * this procedure returns TCL_ERROR and access to the command is * denied. If a command is not recognized, this procedure returns * TCL_CONTINUE, and lookup continues via the normal Tcl name * resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassCmdResolver( Tcl_Interp *interp, /* current interpreter */ CONST char* name, /* name of the command being accessed */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ int flags, /* TCL_LEAVE_ERR_MSG => leave error messages * in interp if anything goes wrong */ Tcl_Command *rPtr) /* returns: resolved command */ { Tcl_HashEntry *hPtr; ItclClass *iclsPtr; ItclObjectInfo *infoPtr; ItclMemberFunc *imPtr; int isCmdDeleted; if ((name[0] == 't') && (strcmp(name, "this") == 0)) { return TCL_CONTINUE; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { return TCL_CONTINUE; } iclsPtr = Tcl_GetHashValue(hPtr); /* * If the command is a member function */ hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, name); if (hPtr == NULL) { #ifdef NOTDEF if (!(iclsPtr->flags & ITCL_CLASS)) { namePtr = Tcl_NewStringObj(name, -1); Tcl_IncrRefCount(namePtr); hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)namePtr); Tcl_DecrRefCount(namePtr); if (hPtr != NULL) { } } if (hPtr == NULL) { #endif return TCL_CONTINUE; #ifdef NOTDEF } imPtr = (ItclMemberFunc*)Tcl_GetHashValue(hPtr); #endif } else { ItclCmdLookup *clookup; clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr = clookup->imPtr; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* FIXME check if called from an (instance) method (not from a typemethod) and only then error */ int isOk = 0; if (strcmp(name, "info") == 0) { isOk = 1; } if (strcmp(name, "mytypemethod") == 0) { isOk = 1; } if (strcmp(name, "myproc") == 0) { isOk = 1; } if (strcmp(name, "mymethod") == 0) { isOk = 1; } if (strcmp(name, "mytypevar") == 0) { isOk = 1; } if (strcmp(name, "myvar") == 0) { isOk = 1; } if (strcmp(name, "itcl_hull") == 0) { isOk = 1; } if (strcmp(name, "callinstance") == 0) { isOk = 1; } if (strcmp(name, "getinstancevar") == 0) { isOk = 1; } if (strcmp(name, "installcomponent") == 0) { isOk = 1; } if (! isOk) { if ((imPtr->flags & ITCL_TYPE_METHOD) != 0) { Tcl_AppendResult(interp, "invalid command name \"", name, "\"", NULL); return TCL_ERROR; } if ((imPtr->flags & ITCL_COMMON) == 0) { /* a method cannot be called directly in ITCL_TYPE * so look, if there is a corresponding proc in the * namespace one level up (i.e. for example ::). If yes * use that. */ Tcl_Namespace *nsPtr2; Tcl_Command cmdPtr; nsPtr2 = Itcl_GetUplevelNamespace(interp, 1); cmdPtr = Tcl_FindCommand(interp, name, nsPtr2, 0); if (cmdPtr != NULL) { *rPtr = cmdPtr; return TCL_OK; } Tcl_AppendResult(interp, "invalid command name \"", name, "\"", NULL); return TCL_ERROR; } } } /* * Looks like we found an accessible member function. * * TRICKY NOTE: Check to make sure that the command handle * is still valid. If someone has deleted or renamed the * command, it may not be. This is just the time to catch * it--as it is being resolved again by the compiler. */ /* * The following #if is needed so itcl can be compiled with * all versions of Tcl. The integer "deleted" was renamed to * "flags" in tcl8.4a2. This #if is also found in itcl_ensemble.c . * We're using a runtime check with itclCompatFlags to adjust for * the behavior of this change, too. * */ /* FIXME !!! */ isCmdDeleted = 0; /* isCmdDeleted = (!imPtr->accessCmd || imPtr->accessCmd->flags); */ if (isCmdDeleted) { imPtr->accessCmd = NULL; if ((flags & TCL_LEAVE_ERR_MSG) != 0) { Tcl_AppendResult(interp, "can't access \"", name, "\": deleted or redefined\n", "(use the \"body\" command to redefine methods/procs)", (char*)NULL); } return TCL_ERROR; /* disallow access! */ } *rPtr = imPtr->accessCmd; return TCL_OK; } /* #define VAR_DEBUG */ /* * ------------------------------------------------------------------------ * Itcl_ClassVarResolver() * * Used by the class namespaces to handle name resolution for runtime * variable accesses. This procedure looks for references to both * common variables and instance variables at runtime. It is used as * a second line of defense, to handle references that could not be * resolved as compiled locals. * * If a variable is found, this procedure returns TCL_OK along with * the appropriate Tcl variable in the rPtr argument. If a particular * variable is private, this procedure returns TCL_ERROR and access * to the variable is denied. If a variable is not recognized, this * procedure returns TCL_CONTINUE, and lookup continues via the normal * Tcl name resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassVarResolver( Tcl_Interp *interp, /* current interpreter */ CONST char* name, /* name of the variable being accessed */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ int flags, /* TCL_LEAVE_ERR_MSG => leave error messages * in interp if anything goes wrong */ Tcl_Var *rPtr) /* returns: resolved variable */ { ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclObject *contextIoPtr; Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; Tcl_Namespace *upNsPtr; upNsPtr = Itcl_GetUplevelNamespace(interp, 1); assert(Itcl_IsClassNamespace(nsPtr)); #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!%s!\n", nsPtr->fullName, name); #endif /* * If this is a global variable, handle it in the usual * Tcl manner. */ if (flags & TCL_GLOBAL_ONLY) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret1\n", name); #endif return TCL_CONTINUE; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret2\n", name); #endif return TCL_CONTINUE; } iclsPtr = Tcl_GetHashValue(hPtr); /* * See if this is a formal parameter in the current proc scope. * If so, that variable has precedence. Look it up and return * it here. This duplicates some of the functionality of * TclLookupVar, but we return it here (instead of returning * TCL_CONTINUE) to avoid looking it up again later. */ ItclCallContext *callContextPtr; callContextPtr = Itcl_PeekStack(&infoPtr->contextStack); if ((strstr(name,"::") == NULL) && Itcl_IsCallFrameArgument(interp, name)) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret3\n", name); #endif return TCL_CONTINUE; } /* * See if the variable is a known data member and accessible. */ hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); if (hPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret4\n", name); #endif return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (!vlookup->accessible) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret5\n", name); #endif return TCL_CONTINUE; } /* * If this is a common data member, then its variable * is easy to find. Return it directly. */ if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { *rPtr = Tcl_GetHashValue(hPtr); #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret6\n", name); #endif return TCL_OK; } } /* * If this is an instance variable, then we have to * find the object context, */ if (callContextPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret7\n", name); #endif return TCL_CONTINUE; } if (callContextPtr->ioPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret8\n", name); #endif return TCL_CONTINUE; } contextIoPtr = callContextPtr->ioPtr; /* * TRICKY NOTE: We've resolved the variable in the current * class context, but we must also be careful to get its * index from the most-specific class context. Variables * are arranged differently depending on which class * constructed the object. */ if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } } } hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)vlookup->ivPtr); if (strcmp(name, "this") == 0) { Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->namePtr), -1); if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { /* deletion of class is running */ Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); } else { Tcl_DStringAppend(&buffer, vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::this", 6); Tcl_Var varPtr; varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { *rPtr = varPtr; #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret9\n", name); #endif return TCL_OK; } } if (strcmp(name, "itcl_options") == 0) { Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->namePtr), -1); Tcl_DStringAppend(&buffer, "::itcl_options", -1); Tcl_Var varPtr; varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { *rPtr = varPtr; #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret10\n", name); #endif return TCL_OK; } } if (hPtr != NULL) { *rPtr = Tcl_GetHashValue(hPtr); #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret11\n", name); #endif return TCL_OK; } #ifdef VAR_DEBUG fprintf(stderr, "CVAR!%s!ret12\n", name); #endif return TCL_CONTINUE; } /* * ------------------------------------------------------------------------ * Itcl_ClassCompiledVarResolver() * * Used by the class namespaces to handle name resolution for compile * time variable accesses. This procedure looks for references to * both common variables and instance variables at compile time. If * the variables are found, they are characterized in a generic way * by their ItclVarLookup record. At runtime, Tcl constructs the * compiled local variables by calling ItclClassRuntimeVarResolver. * * If a variable is found, this procedure returns TCL_OK along with * information about the variable in the rPtr argument. If a particular * variable is private, this procedure returns TCL_ERROR and access * to the variable is denied. If a variable is not recognized, this * procedure returns TCL_CONTINUE, and lookup continues via the normal * Tcl name resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassCompiledVarResolver( Tcl_Interp *interp, /* current interpreter */ CONST char* name, /* name of the variable being accessed */ int length, /* number of characters in name */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to * resolve the variable at runtime */ { ItclClass *iclsPtr; ItclObjectInfo *infoPtr; Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; char *buffer; char storage[64]; #ifdef VAR_DEBUG fprintf(stderr, "CCVAR!%s!%s!\n", nsPtr->fullName, name); #endif assert(Itcl_IsClassNamespace(nsPtr)); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CCVAR!%s!ret1\n", name); #endif return TCL_CONTINUE; } iclsPtr = Tcl_GetHashValue(hPtr); /* * Copy the name to local storage so we can NULL terminate it. * If the name is long, allocate extra space for it. */ if (length < sizeof(storage)) { buffer = storage; } else { buffer = (char*)ckalloc((unsigned)(length+1)); } memcpy((void*)buffer, (void*)name, (size_t)length); buffer[length] = '\0'; hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, buffer); if (buffer != storage) { ckfree(buffer); } /* * If the name is not found, or if it is inaccessible, * continue on with the normal Tcl name resolution rules. */ if (hPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CCVAR!%s!ret2\n", name); #endif return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (!vlookup->accessible) { #ifdef VAR_DEBUG fprintf(stderr, "CCVAR!%s!ret3\n", name); #endif return TCL_CONTINUE; } /* * Return the ItclVarLookup record. At runtime, Tcl will * call ItclClassRuntimeVarResolver with this record, to * plug in the appropriate variable for the current object * context. */ (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); (*rPtr)->fetchProc = ItclClassRuntimeVarResolver; (*rPtr)->deleteProc = NULL; ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; #ifdef VAR_DEBUG fprintf(stderr, "CCVAR!%s!ret4\n", name); #endif return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclClassRuntimeVarResolver() * * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc * at runtime. Resolves data members identified earlier by * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation * for the data member. * ------------------------------------------------------------------------ */ static Tcl_Var ItclClassRuntimeVarResolver( Tcl_Interp *interp, /* current interpreter */ Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep * for variable */ { ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; ItclClass *iclsPtr; ItclObject *contextIoPtr; Tcl_HashEntry *hPtr; /* * If this is a common data member, then the associated * variable is known directly. */ if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "itcl_hull") == 0) { hPtr = NULL; } if (hPtr != NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!%s!ret1!%d!\n", Tcl_GetCurrentNamespace(interp)->fullName, Tcl_GetString(vlookup->ivPtr->namePtr), vlookup->ivPtr->protection); #endif return Tcl_GetHashValue(hPtr); } } iclsPtr = vlookup->ivPtr->iclsPtr; /* * Otherwise, get the current object context and find the * variable in its data table. * * TRICKY NOTE: Get the index for this variable using the * virtual table for the MOST-SPECIFIC class. */ ItclCallContext *callContextPtr; callContextPtr = Itcl_PeekStack(&iclsPtr->infoPtr->contextStack); if (callContextPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret2\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return NULL; } if (callContextPtr->ioPtr == NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret3\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return NULL; } contextIoPtr = callContextPtr->ioPtr; if (contextIoPtr != NULL) { if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { hPtr = Tcl_FindHashEntry(&contextIoPtr->iclsPtr->resolveVars, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } else { } } hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)vlookup->ivPtr); if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->namePtr), -1); if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); } else { Tcl_DStringAppend(&buffer, vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::this", 6); Tcl_Var varPtr; varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret4\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return varPtr; } } if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "itcl_options") == 0) { Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, Tcl_GetString(contextIoPtr->namePtr), -1); Tcl_DStringAppend(&buffer, "::itcl_options", -1); Tcl_Var varPtr; varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret5\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return varPtr; } } if (hPtr != NULL) { #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret6\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return (Tcl_Var)Tcl_GetHashValue(hPtr); } } else { } #ifdef VAR_DEBUG fprintf(stderr, "CRVAR!%s!ret7\n", Tcl_GetString(vlookup->ivPtr->namePtr)); #endif return NULL; } /* * ------------------------------------------------------------------------ * Itcl_ParseVarResolver() * * Used by the "parser" namespace to resolve variable accesses to * common variables. The runtime resolver procedure is consulted * whenever a variable is accessed within the namespace. It can * deny access to certain variables, or perform special lookups itself. * * This procedure allows access only to "common" class variables that * have been declared within the class or inherited from another class. * A "set" command can be used to initialized common data members within * the body of the class definition itself: * * itcl::class Foo { * common colors * set colors(red) #ff0000 * set colors(green) #00ff00 * set colors(blue) #0000ff * ... * } * * itcl::class Bar { * inherit Foo * set colors(gray) #a0a0a0 * set colors(white) #ffffff * * common numbers * set numbers(0) zero * set numbers(1) one * } * * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ParseVarResolver( Tcl_Interp *interp, /* current interpreter */ const char* name, /* name of the variable being accessed */ Tcl_Namespace *contextNs, /* namespace context */ int flags, /* TCL_GLOBAL_ONLY => global variable * TCL_NAMESPACE_ONLY => namespace variable */ Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; /* * See if the requested variable is a recognized "common" member. * If it is, make sure that access is allowed. */ hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name); if (hPtr) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { if (!vlookup->accessible) { Tcl_AppendResult(interp, "can't access \"", name, "\": ", Itcl_ProtectionStr(vlookup->ivPtr->protection), " variable", (char*)NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { *rPtr = Tcl_GetHashValue(hPtr); return TCL_OK; } } } /* * If the variable is not recognized, return TCL_CONTINUE and * let lookup continue via the normal name resolution rules. * This is important for variables like "errorInfo" * that might get set while the parser namespace is active. */ return TCL_CONTINUE; } int ItclSetParserResolver( Tcl_Namespace *nsPtr) { Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL, Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); return TCL_OK; }