Itcl - the [incr Tcl] extension

 *
 *      that is the starting point when loading the library
 *      it initializes all internal stuff
 *
 * ------------------------------------------------------------------------
 */

#ifdef NEW_PROTO_RESOLVER
int ItclVarsAndCommandResolveInit(Tcl_Interp *interp);
#endif

static int
Initialize (
    Tcl_Interp *interp)
{
    Tcl_Namespace *nsPtr;
    Tcl_Namespace *itclNs;
    Tcl_HashEntry *hPtr;

    infoPtr->useOldResolvers = opt;
    Itcl_InitStack(&infoPtr->clsStack);

    Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, (ClientData)infoPtr);

    Itcl_PreserveData((ClientData)infoPtr);

#ifdef NEW_PROTO_RESOLVER
    ItclVarsAndCommandResolveInit(interp);
#endif

    objPtr = Tcl_NewStringObj("::oo::class", -1);
    Tcl_IncrRefCount(objPtr);
    clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
    if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
	Tcl_DecrRefCount(objPtr);
        return TCL_ERROR;
    }

	Tcl_AppendResult(interp,
	        "ITCL: cannot create/get class namespace for class \"",
		Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL);
        return TCL_ERROR;
    }

    if (iclsPtr->infoPtr->useOldResolvers) {
#ifdef NEW_PROTO_RESOLVER
        Itcl_SetNamespaceResolvers(ooNs,
                (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2,
                (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2,
                (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2);
        Itcl_SetNamespaceResolvers(classNs,
                (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver2,
                (Tcl_ResolveVarProc*)Itcl_ClassVarResolver2,
                (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver2);
#else
        Itcl_SetNamespaceResolvers(ooNs,
                (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver,
                (Tcl_ResolveVarProc*)Itcl_ClassVarResolver,
                (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver);
        Itcl_SetNamespaceResolvers(classNs,
                (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver,
                (Tcl_ResolveVarProc*)Itcl_ClassVarResolver,
                (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver);
#endif
    } else {
        Tcl_SetNamespaceResolver(ooNs, iclsPtr->resolvePtr);
        Tcl_SetNamespaceResolver(classNs, iclsPtr->resolvePtr);
    }
    iclsPtr->nsPtr = classNs;

    ItclVarLookup *vlookup;
    ItclVariable *ivPtr;
    ItclMemberFunc *imPtr;
    ItclDelegatedFunction *idmPtr;
    ItclHierIter hier;
    ItclClass *iclsPtr2;
    ItclCmdLookup *clookupPtr;
#ifdef NEW_PROTO_RESOLVER
    ItclClassVarInfo *icviPtr;
    ItclClassCmdInfo *icciPtr;
#endif
    int newEntry;

    Tcl_DStringInit(&buffer);
    Tcl_DStringInit(&buffer2);

    /*
     *  Clear the variable resolution table.

     *  into the table.
     */
    Itcl_InitHierIter(&hier, iclsPtr);
    iclsPtr2 = Itcl_AdvanceHierIter(&hier);
    while (iclsPtr2 != NULL) {
        hPtr = Tcl_FirstHashEntry(&iclsPtr2->variables, &place);
        while (hPtr) {
#ifdef NEW_PROTO_RESOLVER
            int type = VAR_TYPE_VARIABLE;
#endif
            ivPtr = (ItclVariable*)Tcl_GetHashValue(hPtr);

            vlookup = (ItclVarLookup *)ckalloc(sizeof(ItclVarLookup));
            vlookup->ivPtr = ivPtr;
            vlookup->usage = 0;
            vlookup->leastQualName = NULL;

            /*
             *  If this variable is PRIVATE to another class scope,
             *  then mark it as "inaccessible".
             */
            vlookup->accessible = (ivPtr->protection != ITCL_PRIVATE ||
	            ivPtr->iclsPtr == iclsPtr);

	    if (ivPtr->flags & ITCL_COMMON) {
#ifdef NEW_PROTO_RESOLVER
	        type = VAR_TYPE_COMMON;
#endif
	    }
            /*
             *  If this is a reference to the built-in "this"
             *  variable, then its index is "0".  Otherwise,
             *  add another slot to the end of the table.
             */
            if ((ivPtr->flags & ITCL_THIS_VAR) != 0) {
	        vlookup->varNum = 0;
	    } else {
		if ((ivPtr->flags & ITCL_OPTIONS_VAR) != 0) {
	            vlookup->varNum = 1;
		} else {
		    vlookup->varNum = iclsPtr->numInstanceVars++;
	        }
	    }
#ifdef NEW_PROTO_RESOLVER
	    icviPtr = (ItclClassVarInfo *)ckalloc(
	            sizeof(ItclClassVarInfo));
	    icviPtr->type = type;
	    icviPtr->protection = ivPtr->protection;
	    icviPtr->nsPtr = iclsPtr->nsPtr;
	    icviPtr->declaringNsPtr = iclsPtr2->nsPtr;
	    icviPtr->varNum = vlookup->varNum;
	    ClientData clientData2;
            clientData2 = Itcl_RegisterClassVariable(
	            iclsPtr->infoPtr->interp, iclsPtr2->nsPtr,
		    Tcl_GetString(ivPtr->namePtr), icviPtr);
	    vlookup->classVarInfoPtr = clientData2;
#endif
/* FIXME !!! should use for var lookup !! */

            /*
             *  Create all possible names for this variable and enter
             *  them into the variable resolution table:
             *     var
             *     class::var

                    Tcl_SetHashValue(hPtr, (ClientData)vlookup);
                    vlookup->usage++;

                    if (!vlookup->leastQualName) {
                        vlookup->leastQualName =
                            Tcl_GetHashKey(&iclsPtr->resolveVars, hPtr);
                    }
#ifdef NEW_PROTO_RESOLVER
                    Itcl_RegisterClassVariable(iclsPtr->infoPtr->interp,
		        iclsPtr->nsPtr, Tcl_DStringValue(&buffer),
		        vlookup->classVarInfoPtr);
#endif
                }

                if (nsPtr == NULL) {
                    break;
                }
                Tcl_DStringSetLength(&buffer2, 0);
                Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);

                        (char *)objPtr, &newEntry);

                if (newEntry) {
		    clookupPtr = (ItclCmdLookup *)ckalloc(sizeof(ItclCmdLookup));
		    memset(clookupPtr, 0, sizeof(ItclCmdLookup));
		    clookupPtr->imPtr = imPtr;
                    Tcl_SetHashValue(hPtr, (ClientData)clookupPtr);
#ifdef NEW_PROTO_RESOLVER
                    int type = CMD_TYPE_METHOD;
	            if (imPtr->flags & ITCL_COMMON) {
	                type = CMD_TYPE_PROC;
	            }
	            icciPtr = (ItclClassCmdInfo *)ckalloc(
	                    sizeof(ItclClassCmdInfo));
	            icciPtr->type = type;
	            icciPtr->protection = imPtr->protection;
	            icciPtr->nsPtr = iclsPtr->nsPtr;
	            icciPtr->declaringNsPtr = iclsPtr2->nsPtr;
	            ClientData clientData2;
                    clientData2 = Itcl_RegisterClassCommand(
	                    iclsPtr->infoPtr->interp, iclsPtr->nsPtr,
		            Tcl_GetString(imPtr->namePtr), icciPtr);
		    clookupPtr->classCmdInfoPtr = clientData2;
		    clookupPtr->cmdPtr = imPtr->accessCmd;
#endif
                } else {
		    Tcl_DecrRefCount(objPtr);
		}

                if (nsPtr == NULL) {
                    break;
                }

            Tcl_SetHashValue(hPtr, (ClientData)vlookup);
            vlookup->usage++;

            if (!vlookup->leastQualName) {
                vlookup->leastQualName =
                    Tcl_GetHashKey(&contextIclsPtr->resolveVars, hPtr);
            }
#ifdef NEW_PROTO_RESOLVER
            Itcl_RegisterClassVariable(contextIclsPtr->infoPtr->interp,
                     contextIclsPtr->nsPtr, Tcl_DStringValue(&buffer),
                     vlookup->classVarInfoPtr);
#endif
        }

        if (nsPtr == NULL) {
            break;
        }
        Tcl_DStringSetLength(&buffer2, 0);
        Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1);

     *  name.  Use normal class names when possible.
     */
    if (contextIoPtr) {
        contextNs = contextIoPtr->iclsPtr->nsPtr;
    } else {
        assert(contextIclsPtr != NULL);
        assert(contextIclsPtr->nsPtr != NULL);
#ifdef NEW_PROTO_RESOLVER
        contextNs = contextIclsPtr->nsPtr;
#else
        if (contextIclsPtr->infoPtr->useOldResolvers) {
            contextNs = contextIclsPtr->nsPtr;
        } else {
            contextNs = contextIclsPtr->nsPtr;
        }
#endif
    }

            name = contextNs->fullName;
    if (!(contextIclsPtr->flags & ITCL_WIDGET)) {
	Tcl_AppendResult(interp, "object or class is no widget", NULL);
        return TCL_ERROR;
    }

     *  name.  Use normal class names when possible.
     */
    if (contextIoPtr) {
        contextNs = contextIoPtr->iclsPtr->nsPtr;
    } else {
        assert(contextIclsPtr != NULL);
        assert(contextIclsPtr->nsPtr != NULL);
#ifdef NEW_PROTO_RESOLVER
        contextNs = contextIclsPtr->nsPtr;
#else
        if (contextIclsPtr->infoPtr->useOldResolvers) {
            contextNs = contextIclsPtr->nsPtr;
        } else {
            contextNs = contextIclsPtr->nsPtr;
        }
#endif
    }

            name = contextNs->fullName;
    if (!(contextIclsPtr->flags & ITCL_TYPE)) {
	Tcl_AppendResult(interp, "object or class is no type", NULL);
        return TCL_ERROR;
    }

     *  name.  Use normal class names when possible.
     */
    if (contextIoPtr) {
        contextNs = contextIoPtr->iclsPtr->nsPtr;
    } else {
        assert(contextIclsPtr != NULL);
        assert(contextIclsPtr->nsPtr != NULL);
#ifdef NEW_PROTO_RESOLVER
        contextNs = contextIclsPtr->nsPtr;
#else
        if (contextIclsPtr->infoPtr->useOldResolvers) {
            contextNs = contextIclsPtr->nsPtr;
        } else {
            contextNs = contextIclsPtr->nsPtr;
        }
#endif
    }

            name = contextNs->fullName;
    if (!(contextIclsPtr->flags & ITCL_WIDGETADAPTOR)) {
	Tcl_AppendResult(interp, "object or class is no widgetadaptor", NULL);
        return TCL_ERROR;
    }

    Tcl_Obj *defaultValuePtr;
    Tcl_Obj *callbackPtr;
} ItclMethodVariable;

#define VAR_TYPE_VARIABLE 	1
#define VAR_TYPE_COMMON 	2

typedef struct ItclClassVarInfo {
    int type;
    int protection;
    int varNum;
    Tcl_Namespace *nsPtr;
    Tcl_Namespace *declaringNsPtr;
} ItclClassVarInfo;

#define CMD_TYPE_METHOD 	1
#define CMD_TYPE_PROC 		2

typedef struct ItclClassCmdInfo {
    int type;
    int protection;
    int cmdNum;

    int accessible;           /* non-zero => accessible from class with
                               * this lookup record in its resolveVars */
    char *leastQualName;      /* simplist name for this variable, with
                               * the fewest qualifiers.  This string is
                               * taken from the resolveVars table, so
                               * it shouldn't be freed. */
    int varNum;
    ItclClassVarInfo *classVarInfoPtr;
    Tcl_Var varPtr;
} ItclVarLookup;

/*
 *  Instance command lookup entry.
 */
typedef struct ItclCmdLookup {

MODULE_SCOPE const Tcl_MethodType itclRootMethodType;
MODULE_SCOPE ItclRootMethodProc ItclUnknownGuts;
MODULE_SCOPE ItclRootMethodProc ItclConstructGuts;
MODULE_SCOPE ItclRootMethodProc ItclInfoGuts;

#include "itcl2TclOO.h"
#ifdef NEW_PROTO_RESOLVER
#include "itclVarsAndCmds.h"
#endif

/*
 * Include all the private API, generated from itcl.decls.
 */

#include "itclIntDecls.h"

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  These procedures handle command and variable resolution
 *
 * ========================================================================
 *  AUTHOR:  Arnulf Wiedemann
 *
 * ========================================================================
 *           Copyright (c) Arnulf Wiedemann
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */
#include <tclInt.h>
#include "itclInt.h"
#include "itclVCInt.h"

/*
 * 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 ItclClassRuntimeVarResolver2 (
    Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr);

int
Itcl_CheckClassVariableProtection(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    const char *varName,
    ClientData clientData)
{
    ItclClassVarInfo *icviPtr;

    icviPtr = (ItclClassVarInfo *)clientData;
    if (icviPtr->protection == ITCL_PRIVATE) {
        if (icviPtr->declaringNsPtr != nsPtr) {
	    Tcl_AppendResult(interp, "can't read \"", varName,
	            "\": no such variable", NULL);
	    return TCL_ERROR;
        }
    }
    return TCL_OK;
}

int
Itcl_CheckClassCommandProtection(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    const char *commandName,
    ClientData clientData)
{
    /* FIXME need code here !!! */
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  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_ClassCmdResolver2(
    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 */
{
    ItclClass *iclsPtr;
    ItclObjectInfo *infoPtr;
    ItclObject *contextIoPtr;

    Tcl_Command cmdPtr;
    ItclResolvingInfo *iriPtr;
    ObjectCmdTableInfo *octiPtr;
    ObjectCmdInfo *ociPtr;
    Tcl_HashEntry *hPtr;

    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);
    ItclCallContext *callContextPtr;
    callContextPtr = Itcl_PeekStack(&infoPtr->contextStack);
    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_FindHashEntry(&iriPtr->resolveCmds , nsPtr->fullName);
    if (hPtr != NULL) {
	Tcl_HashTable *tablePtr;
	tablePtr = Tcl_GetHashValue(hPtr);
        hPtr = Tcl_FindHashEntry(tablePtr, name);
        if (hPtr != NULL) {
	    ItclClassCmdInfo *icciPtr = Tcl_GetHashValue(hPtr);
            if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) {
                contextIoPtr = callContextPtr->ioPtr;
                hPtr = Tcl_FindHashEntry(&iriPtr->objectCmdsTables,
		        (char *)contextIoPtr);
	        if (hPtr != NULL) {
	            octiPtr = Tcl_GetHashValue(hPtr);
	            hPtr = Tcl_FindHashEntry(&octiPtr->cmdInfos,
		           (char *)icciPtr);
	            if (hPtr != NULL) {
			int ret;
			ociPtr = Tcl_GetHashValue(hPtr);
			ret = (* iriPtr->cmdProtFcn)(interp,
			        Tcl_GetCurrentNamespace(interp), name,
				(ClientData)icciPtr);
			if (ret != TCL_OK) {
			    return ret;
			}
		        cmdPtr = ociPtr->cmdPtr;
                        *rPtr = cmdPtr;
	                return TCL_OK;
		    }
	        }
	    }
	}
    }
    return TCL_CONTINUE;
}


/*
 * ------------------------------------------------------------------------
 *  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_ClassVarResolver2(
    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_Var varPtr;
    ItclResolvingInfo *iriPtr;
    ObjectVarTableInfo *ovtiPtr;
    ObjectVarInfo *oviPtr;

    Tcl_Namespace *upNsPtr;
    upNsPtr = Itcl_GetUplevelNamespace(interp, 1);

    /*
     *  If this is a global variable, handle it in the usual
     *  Tcl manner.
     */
    if (flags & TCL_GLOBAL_ONLY) {
        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);

    /*
     *  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)) {
        return TCL_CONTINUE;
    }

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars , nsPtr->fullName);
    if (hPtr != NULL) {
	Tcl_HashTable *tablePtr;
	tablePtr = Tcl_GetHashValue(hPtr);
        hPtr = Tcl_FindHashEntry(tablePtr , name);
        if (hPtr != NULL) {
	    int ret;
	    ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr);
	    ret = (* iriPtr->varProtFcn)(interp,
	            Tcl_GetCurrentNamespace(interp), name,
		    (ClientData)icviPtr);
	    if (ret != TCL_OK) {
	        return ret;
	    }
            /*
             *  If this is an instance variable, then we have to
             *  find the object context,
             */

            if ((callContextPtr != NULL) && (callContextPtr->ioPtr != NULL)) {
                contextIoPtr = callContextPtr->ioPtr;
                hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables,
		        (char *)contextIoPtr);
	        if (hPtr != NULL) {
	            ovtiPtr = Tcl_GetHashValue(hPtr);
	            hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos,
		           (char *)icviPtr);
	            if (hPtr != NULL) {
			oviPtr = Tcl_GetHashValue(hPtr);
		        varPtr = oviPtr->varPtr;
                        *rPtr = varPtr;
	                return TCL_OK;
		    }
	        }
	    }
	}
    }
    /*
     *  See if the variable is a known data member and accessible.
     */
    hPtr = Tcl_FindHashEntry(&iclsPtr->resolveVars, name);
    if (hPtr == NULL) {
        return TCL_CONTINUE;
    }

    vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
    if (!vlookup->accessible) {
        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);
            return TCL_OK;
	}
    }

    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_ClassCompiledVarResolver2(
    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];

    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);
    /*
     *  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) {
        return TCL_CONTINUE;
    }

    vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
    if (!vlookup->accessible) {
        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 = ItclClassRuntimeVarResolver2;
    (*rPtr)->deleteProc = NULL;
    ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup;

    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
ItclClassRuntimeVarResolver2(
    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;

    Tcl_Var varPtr;
    ItclResolvingInfo *iriPtr;
    ObjectVarTableInfo *ovtiPtr;
    ObjectVarInfo *oviPtr;

    /*
     *  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 (hPtr != NULL) {
	    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) {
        return NULL;
    }
    if (callContextPtr->ioPtr == NULL) {
        return NULL;
    }
    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_FindHashEntry(&iriPtr->resolveVars,
            Tcl_GetCurrentNamespace(interp)->fullName);
    if (hPtr != NULL) {
        Tcl_HashTable *tablePtr;
	tablePtr = Tcl_GetHashValue(hPtr);
        hPtr = Tcl_FindHashEntry(tablePtr,
	        Tcl_GetString(vlookup->ivPtr->namePtr));
        if (hPtr != NULL) {
	    ItclClassVarInfo *icviPtr = Tcl_GetHashValue(hPtr);
	    int ret;
	    ret = (* iriPtr->varProtFcn)(interp,
	            Tcl_GetCurrentNamespace(interp),
		    Tcl_GetString(vlookup->ivPtr->namePtr),
		    (ClientData)icviPtr);
	    if (ret != TCL_OK) {
	        return NULL;
	    }
            /*
             *  If this is an instance variable, then we have to
             *  find the object context,
             */

            contextIoPtr = callContextPtr->ioPtr;
            hPtr = Tcl_FindHashEntry(&iriPtr->objectVarsTables, (char *)contextIoPtr);
	    if (hPtr != NULL) {
	        ovtiPtr = Tcl_GetHashValue(hPtr);
	        hPtr = Tcl_FindHashEntry(&ovtiPtr->varInfos, (char *)icviPtr);
	        if (hPtr != NULL) {
	            oviPtr = Tcl_GetHashValue(hPtr);
		    varPtr = oviPtr->varPtr;
	            return varPtr;
	        }
	    }
	}
    }
    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_ParseVarResolver2(
    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
ItclSetParserResolver2(
    Tcl_Namespace *nsPtr)
{
    Itcl_SetNamespaceResolvers(nsPtr, (Tcl_ResolveCmdProc*)NULL,
            Itcl_ParseVarResolver2, (Tcl_ResolveCompiledVarProc*)NULL);
    return TCL_OK;
}

#define ITCL_RESOLVE_DATA "ITCL_Resolve_Info"

typedef struct ItclResolvngInfo {
    Tcl_Interp *interp;
    Tcl_HashTable resolveVars;    /* all possible names for variables in
                                   * this class (e.g., x, foo::x, etc.) */
    Tcl_HashTable resolveCmds;    /* all possible names for functions in
                                   * this class (e.g., x, foo::x, etc.) */
    ItclCheckClassProtection *varProtFcn;
    ItclCheckClassProtection *cmdProtFcn;
    Tcl_HashTable objectVarsTables;
    Tcl_HashTable objectCmdsTables;
} ItclResolvingInfo;

typedef struct ObjectVarInfo {
    ClientData clientData;
    ItclObject *ioPtr;
    Tcl_Var varPtr;
} ObjectVarInfo;

typedef struct ObjectVarTableInfo {
    Tcl_HashTable varInfos;
    TclVarHashTable *tablePtr;
} ObjectVarTableInfo;

typedef struct ObjectCmdInfo {
    ClientData clientData;
    ItclObject *ioPtr;
    Tcl_Command cmdPtr;
} ObjectCmdInfo;

typedef struct ObjectCmdTableInfo {
    Tcl_HashTable cmdInfos;
    Tcl_HashTable *tablePtr;
} ObjectCmdTableInfo;

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  These procedures handle command and variable resolution
 *
 * ========================================================================
 *  AUTHOR:  Arnulf Wiedemann
 *
 * ========================================================================
 *           Copyright (c) Arnulf Wiedemann
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include <tclInt.h>
#include "itclInt.h"
#include "itclVCInt.h"

#ifdef NEW_PROTO_RESOLVER
static void
ItclDeleteResolveInfo(
    ClientData clientData,
    Tcl_Interp *interp)
{
    ckfree((char *)clientData);
}
#endif

int
ItclVarsAndCommandResolveInit(
    Tcl_Interp *interp)
{
#ifdef NEW_PROTO_RESOLVER
    ItclResolvingInfo *iriPtr;

    /*
     *  Create the top-level data structure for tracking objects.
     *  Store this as "associated data" for easy access, but link
     *  it to the itcl namespace for ownership.
     */
    iriPtr = (ItclResolvingInfo*)ckalloc(sizeof(ItclResolvingInfo));
    memset(iriPtr, 0, sizeof(ItclResolvingInfo));
    iriPtr->interp = interp;
    Tcl_InitHashTable(&iriPtr->resolveVars, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(&iriPtr->resolveCmds, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(&iriPtr->objectVarsTables, TCL_ONE_WORD_KEYS);
    Tcl_InitHashTable(&iriPtr->objectCmdsTables, TCL_ONE_WORD_KEYS);

    Tcl_SetAssocData(interp, ITCL_RESOLVE_DATA,
        (Tcl_InterpDeleteProc*)ItclDeleteResolveInfo, (ClientData)iriPtr);
    Tcl_Preserve((ClientData)iriPtr);

    Itcl_SetClassCommandProtectionCallback(interp, NULL,
            Itcl_CheckClassCommandProtection);
    Itcl_SetClassVariableProtectionCallback(interp, NULL,
            Itcl_CheckClassVariableProtection);
#endif
    return TCL_OK;
}

ClientData
Itcl_RegisterClassVariable(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    const char *varName,
    ClientData clientData)
{
    Tcl_HashTable *tablePtr;
    Tcl_HashEntry *hPtr;
    ItclResolvingInfo *iriPtr;
    int isNew;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_CreateHashEntry(&iriPtr->resolveVars, nsPtr->fullName, &isNew);
    if (isNew) {
	tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
        Tcl_SetHashValue(hPtr, tablePtr);

    } else {
        tablePtr = Tcl_GetHashValue(hPtr);
    }
    hPtr = Tcl_CreateHashEntry(tablePtr, varName, &isNew);
    if (isNew) {
        Tcl_SetHashValue(hPtr, clientData);
    }
    return Tcl_GetHashValue(hPtr);
}

ClientData
Itcl_RegisterClassCommand(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    const char *cmdName,
    ClientData clientData)
{
    Tcl_HashEntry *hPtr;
    Tcl_HashTable *tablePtr;
    ItclResolvingInfo *iriPtr;
    int isNew;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_CreateHashEntry(&iriPtr->resolveCmds, nsPtr->fullName, &isNew);
    if (isNew) {
	tablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
        Tcl_SetHashValue(hPtr, tablePtr);

    } else {
        tablePtr = Tcl_GetHashValue(hPtr);
    }
    hPtr = Tcl_CreateHashEntry(tablePtr, cmdName, &isNew);
    if (isNew) {
        Tcl_SetHashValue(hPtr, clientData);
    }
    return Tcl_GetHashValue(hPtr);
}

Tcl_Var
Itcl_RegisterObjectVariable(
    Tcl_Interp *interp,
    ItclObject *ioPtr,
    const char *varName,
    ClientData clientData,
    Tcl_Var varPtr,
    Tcl_Namespace *nsPtr)
{
    Tcl_HashEntry *hPtr;
    ItclResolvingInfo *iriPtr;
    ObjectVarTableInfo *ovtiPtr;
    ObjectVarInfo *oviPtr;
    int isNew;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_CreateHashEntry(&iriPtr->objectVarsTables,
            (char *)ioPtr, &isNew);
    if (isNew) {
	ovtiPtr = (ObjectVarTableInfo *)ckalloc(sizeof(ObjectVarTableInfo));
	Tcl_InitHashTable(&ovtiPtr->varInfos, TCL_ONE_WORD_KEYS);
	ovtiPtr->tablePtr = &((Namespace *)nsPtr)->varTable;
        Tcl_SetHashValue(hPtr, ovtiPtr);
    } else {
        ovtiPtr = Tcl_GetHashValue(hPtr);
    }
    hPtr = Tcl_CreateHashEntry(&ovtiPtr->varInfos, (char *)clientData, &isNew);
    if (isNew) {
	oviPtr = (ObjectVarInfo *)ckalloc(sizeof(ObjectVarInfo));
	memset(oviPtr, 0, sizeof(ObjectVarInfo));
        Tcl_SetHashValue(hPtr, oviPtr);
    } else {
        oviPtr = Tcl_GetHashValue(hPtr);
    }
    oviPtr->clientData = clientData;
    oviPtr->ioPtr = ioPtr;
    if (varPtr == NULL) {
        varPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName);
    }
    oviPtr->varPtr = varPtr;
    return varPtr;
}

Tcl_Command
Itcl_RegisterObjectCommand(
    Tcl_Interp *interp,
    ItclObject *ioPtr,
    const char *cmdName,
    ClientData clientData,
    Tcl_Command cmdPtr,
    Tcl_Namespace *nsPtr)
{
    Tcl_HashEntry *hPtr;
    ItclResolvingInfo *iriPtr;
    ObjectCmdTableInfo *octiPtr;
    ObjectCmdInfo *ociPtr;
    int isNew;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    hPtr = Tcl_CreateHashEntry(&iriPtr->objectCmdsTables,
            (char *)ioPtr, &isNew);
    if (isNew) {
	octiPtr = (ObjectCmdTableInfo *)ckalloc(sizeof(ObjectCmdTableInfo));
	Tcl_InitHashTable(&octiPtr->cmdInfos, TCL_ONE_WORD_KEYS);
	octiPtr->tablePtr = &((Namespace *)nsPtr)->cmdTable;
        Tcl_SetHashValue(hPtr, octiPtr);
    } else {
        octiPtr = Tcl_GetHashValue(hPtr);
    }
    hPtr = Tcl_CreateHashEntry(&octiPtr->cmdInfos, (char *)clientData, &isNew);
    if (isNew) {
	ociPtr = (ObjectCmdInfo *)ckalloc(sizeof(ObjectCmdInfo));
	memset(ociPtr, 0, sizeof(ObjectCmdInfo));
        Tcl_SetHashValue(hPtr, ociPtr);
    } else {
        ociPtr = Tcl_GetHashValue(hPtr);
    }
    ociPtr->clientData = clientData;
    ociPtr->ioPtr = ioPtr;
    if (cmdPtr == NULL) {
/*
        cmdPtr = Tcl_NewNamespaceVar(interp, nsPtr, varName);
*/
    }
    ociPtr->cmdPtr = cmdPtr;
    return cmdPtr;
}

int
Itcl_SetClassVariableProtectionCallback(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    ItclCheckClassProtection *fcnPtr)
{
    ItclResolvingInfo *iriPtr;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    iriPtr->varProtFcn = fcnPtr;
    return TCL_OK;
}

int
Itcl_SetClassCommandProtectionCallback(
    Tcl_Interp *interp,
    Tcl_Namespace *nsPtr,
    ItclCheckClassProtection *fcnPtr)
{
    ItclResolvingInfo *iriPtr;

    iriPtr = Tcl_GetAssocData(interp, ITCL_RESOLVE_DATA, NULL);
    iriPtr->cmdProtFcn = fcnPtr;
    return TCL_OK;
}

/*
 * ------------------------------------------------------------------------
 *      PACKAGE:  [incr Tcl]
 *  DESCRIPTION:  Object-Oriented Extensions to Tcl
 *
 *  These procedures handle command and variable resolution
 *
 * ========================================================================
 *  AUTHOR:  Arnulf Wiedemann
 *
 * ========================================================================
 *           Copyright (c) Arnulf Wiedemann
 * ------------------------------------------------------------------------
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

typedef int (ItclCheckClassProtection)(Tcl_Interp *interp,
         Tcl_Namespace *nsPtr, const char *varName, ClientData clientData);

ClientData Itcl_RegisterClassVariable(Tcl_Interp *interp,
        Tcl_Namespace *nsPtr, const char *varName, ClientData clientData);

Tcl_Var Itcl_RegisterObjectVariable( Tcl_Interp *interp, ItclObject *ioPtr,
	const char *varName, ClientData clientData, Tcl_Var varPtr,
	Tcl_Namespace *nsPtr);

ClientData Itcl_RegisterClassCommand(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
        const char *cmdName, ClientData clientData);

Tcl_Command Itcl_RegisterObjectCommand( Tcl_Interp *interp, ItclObject *ioPtr,
	const char *cmdName, ClientData clientData, Tcl_Command cmdPtr,
	Tcl_Namespace *nsPtr);

int Itcl_CheckClassVariableProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
        const char *varName, ClientData clientData);

int Itcl_CheckClassCommandProtection(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
        const char *cmdName, ClientData clientData);

int Itcl_SetClassVariableProtectionCallback(Tcl_Interp *interp,
         Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr);

int Itcl_SetClassCommandProtectionCallback(Tcl_Interp *interp,
         Tcl_Namespace *nsPtr, ItclCheckClassProtection *fcnPtr);