text: /*
   * ------------------------------------------------------------------------
   *      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);
      assert(Itcl_IsClassNamespace(nsPtr));
  
      /*
       *  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];
  
      assert(Itcl_IsClassNamespace(nsPtr));
  
      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;
  }
  