itcl_class.c

linux 下的源代码分析阅读器 red hat公司新版

 *  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(interp, name, context, flags, rPtr)
    Tcl_Interp *interp;       /* current interpreter */
    char* name;               /* name of the command being accessed */
    Tcl_Namespace *context;   /* 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 *cdefn = (ItclClass*)context->clientData;

    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;
    Command *cmdPtr;

    /*
     *  If the command is a member function, and if it is
     *  accessible, return its Tcl command handle.
     */
    entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name);
    if (!entry) {
        return TCL_CONTINUE;
    }

    mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);


    /*
     *  For protected/private functions, figure out whether or
     *  not the function is accessible from the current context.
     *
     *  TRICKY NOTE:  Use Itcl_GetTrueNamespace to determine
     *    the current context.  If the current call frame is
     *    "transparent", this handles it properly.
     */
    if (mfunc->member->protection != ITCL_PUBLIC) {
        context = Itcl_GetTrueNamespace(interp, cdefn->info);

        if (!Itcl_CanAccessFunc(mfunc, context)) {

            if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "can't access \"", name, "\": ",
                    Itcl_ProtectionStr(mfunc->member->protection),
                    " variable",
                    (char*)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.
     */
    cmdPtr = (Command*)mfunc->accessCmd;
    if (!cmdPtr || cmdPtr->deleted) {
        mfunc->accessCmd = NULL;

        if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(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 = mfunc->accessCmd;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, name, context, flags, rPtr)
    Tcl_Interp *interp;       /* current interpreter */
    char* name;               /* name of the variable being accessed */
    Tcl_Namespace *context;   /* 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 */
{
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;

    ItclClass *cdefn = (ItclClass*)context->clientData;
    ItclObject *contextObj;
    Tcl_CallFrame *framePtr;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;

    assert(Itcl_IsClassNamespace(context));

    /*
     *  If this is a global variable, handle it in the usual
     *  Tcl manner.
     */
    if (flags & TCL_GLOBAL_ONLY) {
        return TCL_CONTINUE;
    }

    /*
     *  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.
     */
    if (varFramePtr && varFramePtr->isProcCallFrame
        && strstr(name,"::") == NULL) {

        Proc *procPtr = varFramePtr->procPtr;

        /*
         *  Search through compiled locals first...
         */
        if (procPtr) {
            int localCt = procPtr->numCompiledLocals;
            CompiledLocal *localPtr = procPtr->firstLocalPtr;
            Var *localVarPtr = varFramePtr->compiledLocals;
            int nameLen = strlen(name);
            int i;

            for (i=0; i < localCt; i++) {
                if (!TclIsVarTemporary(localPtr)) {
                    register char *localName = localVarPtr->name;
                    if ((name[0] == localName[0])
                            && (nameLen == localPtr->nameLength)
                            && (strcmp(name, localName) == 0)) {
                        *rPtr = (Tcl_Var)localVarPtr;
                        return TCL_OK;
                    }
                }
                localVarPtr++;
                localPtr = localPtr->nextPtr;
            }
        }

        /*
         *  If it's not a compiled local, then look in the frame's
         *  var hash table next.  This variable may have been
         *  created on the fly.
         */
        if (varFramePtr->varTablePtr != NULL) {
            entry = Tcl_FindHashEntry(varFramePtr->varTablePtr, name);
            if (entry != NULL) {
                *rPtr = (Tcl_Var)Tcl_GetHashValue(entry);
                return TCL_OK;
            }
        }
    }

    /*
     *  See if the variable is a known data member and accessible.
     */
    entry = Tcl_FindHashEntry(&cdefn->resolveVars, name);
    if (entry == NULL) {
        return TCL_CONTINUE;
    }

    vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
    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->vdefn->member->flags & ITCL_COMMON) != 0) {
        *rPtr = vlookup->var.common;
        return TCL_OK;
    }

    /*
     *  If this is an instance variable, then we have to
     *  find the object context, then index into its data
     *  array to get the actual variable.
     */
    framePtr = _Tcl_GetCallFrame(interp, 0);

    entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
    if (entry == NULL) {
        return TCL_CONTINUE;
    }
    contextObj = (ItclObject*)Tcl_GetHashValue(entry);

    /*
     *  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 (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
        entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
            vlookup->vdefn->member->fullname);

        if (entry) {
            vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        }
    }
    *rPtr = (Tcl_Var)contextObj->data[vlookup->var.index];
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  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(interp, name, length, context, rPtr)
    Tcl_Interp *interp;         /* current interpreter */
    char* name;                 /* name of the variable being accessed */
    int length;                 /* number of characters in name */
    Tcl_Namespace *context;     /* namespace performing the resolution */
    Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to
                                 *   resolve the variable at runtime */
{
    ItclClass *cdefn = (ItclClass*)context->clientData;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;
    char *buffer, storage[64];

    assert(Itcl_IsClassNamespace(context));

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

    entry = Tcl_FindHashEntry(&cdefn->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 (entry == NULL) {
        return TCL_CONTINUE;
    }

    vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
    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 = ItclClassRuntimeVarResolver;
    (*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
ItclClassRuntimeVarResolver(interp, resVarInfo)
    Tcl_Interp *interp;               /* current interpreter */
    Tcl_ResolvedVarInfo *resVarInfo;  /* contains ItclVarLookup rep
                                       * for variable */
{
    ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup;

    Tcl_CallFrame *framePtr;
    ItclClass *cdefn;
    ItclObject *contextObj;
    Tcl_HashEntry *entry;

    /*
     *  If this is a common data member, then the associated
     *  variable is known directly.
     */
    if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) {
        return vlookup->var.common;
    }
    cdefn = vlookup->vdefn->member->classDefn;

    /*
     *  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.
     */
    framePtr = _Tcl_GetCallFrame(interp, 0);

    entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr);
    if (entry) {
        contextObj = (ItclObject*)Tcl_GetHashValue(entry);

        if (contextObj != NULL) {
            if (contextObj->classDefn != vlookup->vdefn->member->classDefn) {
                entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
                    vlookup->vdefn->member->fullname);

                if (entry) {
                    vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
                }
            }
            return (Tcl_Var)contextObj->data[vlookup->var.index];
        }
    }
    return NULL;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BuildVirtualTables()
 *
 *  Invoked whenever the class heritage changes or members are added or
 *  removed from a class definition to rebuild the member lookup
 *  tables.  There are two tables:
 *
 *  METHODS:  resolveCmds
 *    Used primarily in Itcl_ClassCmdResolver() to resolve all
 *    command references in a namespace.
 *
 *  DATA MEMBERS:  resolveVars
 *    Used primarily in Itcl_ClassVarResolver() to quickly resolve
 *    variable references in each class scope.
 *
 *  These tables store every possible name for each command/variable
 *  (member, class::member, namesp::class::member, etc.).  Members
 *  in a derived class may shadow members with the same name in a
 *  base class.  In that case, the simple name in the resolution
 *  table will point to the most-specific member.
 * ------------------------------------------------------------------------
 */
void
Itcl_BuildVirtualTables(cdefnPtr)
    ItclClass* cdefnPtr;       /* class definition being updated */
{
    Tcl_HashEntry *entry, *hPtr;
    Tcl_HashSearch place;
    ItclVarLookup *vlookup;
    ItclVarDefn *vdefn;
    ItclMemberFunc *mfunc;
    ItclHierIter hier;
    ItclClass *cdPtr;
    Namespace* nsPtr;
    Tcl_DString buffer, buffer2;
    int newEntry;

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

    /*
     *  Clear the variable resolution table.
     */
    entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place);
    while (entry) {
        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        if (--vlookup->usage == 0) {
            ckfree((char*)vlookup);
        }
        entry = Tcl_NextHashEntry(&place);
    }
    Tcl_DeleteHashTable(&cdefnPtr->resolveVars);
    Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS);
    cdefnPtr->numInstanceVars = 0;

    /*
     *  Set aside the first object-specific slot for the built-in
     *  "this" variable.  Only allocate one of these, even though
     *  there is a definition for "this" in each class scope.
     */
    cdefnPtr->numInstanceVars++;

    /*
     *  Scan through all classes in the hierarchy, from most to