/*
 * ------------------------------------------------------------------------
 *      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;
}
