itcl_objects.c

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

        elem = Itcl_NextListElem(elem);
    }
    Itcl_DeleteList(&cmdList);
}


/*
 * ------------------------------------------------------------------------
 *  ItclTraceThisVar()
 *
 *  Invoked to handle read/write traces on the "this" variable built
 *  into each object.
 *
 *  On read, this procedure updates the "this" variable to contain the
 *  current object name.  This is done dynamically, since an object's
 *  identity can change if its access command is renamed.
 *
 *  On write, this procedure returns an error string, warning that
 *  the "this" variable cannot be set.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static char*
ItclTraceThisVar(cdata, interp, name1, name2, flags)
    ClientData cdata;        /* object instance data */
    Tcl_Interp *interp;      /* interpreter managing this variable */
    char *name1;             /* variable name */
    char *name2;             /* unused */
    int flags;               /* flags indicating read/write */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    char *objName;
    Tcl_Obj *objPtr;

    /*
     *  Handle read traces on "this"
     */
    if ((flags & TCL_TRACE_READS) != 0) {
        objPtr = Tcl_NewStringObj("", -1);
        Tcl_IncrRefCount(objPtr);

        if (contextObj->accessCmd) {
            Tcl_GetCommandFullName(contextObj->classDefn->interp,
                contextObj->accessCmd, objPtr);
        }

        objName = Tcl_GetStringFromObj(objPtr, (int*)NULL);
        Tcl_SetVar(interp, name1, objName, 0);

        Tcl_DecrRefCount(objPtr);
        return NULL;
    }

    /*
     *  Handle write traces on "this"
     */
    if ((flags & TCL_TRACE_WRITES) != 0) {
        return "variable \"this\" cannot be modified";
    }
    return NULL;
}


/*
 * ------------------------------------------------------------------------
 *  ItclDestroyObject()
 *
 *  Invoked when the object access command is deleted to implicitly
 *  destroy the object.  Invokes the object's destructors, ignoring
 *  any errors encountered along the way.  Removes the object from
 *  the list of all known objects and releases the access command's
 *  claim to the object data.
 *
 *  Note that the usual way to delete an object is via Itcl_DeleteObject().
 *  This procedure is provided as a back-up, to handle the case when
 *  an object is deleted by removing its access command.
 * ------------------------------------------------------------------------
 */
static void
ItclDestroyObject(cdata)
    ClientData cdata;  /* object instance data */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn;
    Tcl_HashEntry *entry;
    Itcl_InterpState istate;

    /*
     *  Attempt to destruct the object, but ignore any errors.
     */
    istate = Itcl_SaveInterpState(cdefnPtr->interp, 0);
    Itcl_DestructObject(cdefnPtr->interp, contextObj, ITCL_IGNORE_ERRS);
    Itcl_RestoreInterpState(cdefnPtr->interp, istate);

    /*
     *  Now, remove the object from the global object list.
     *  We're careful to do this here, after calling the destructors.
     *  Once the access command is nulled out, the "this" variable
     *  won't work properly.
     */
    if (contextObj->accessCmd) {
        entry = Tcl_FindHashEntry(&cdefnPtr->info->objects,
            (char*)contextObj->accessCmd);

        if (entry) {
            Tcl_DeleteHashEntry(entry);
        }
        contextObj->accessCmd = NULL;
    }

    Itcl_ReleaseData((ClientData)contextObj);
}


/*
 * ------------------------------------------------------------------------
 *  ItclFreeObject()
 *
 *  Deletes all instance variables and frees all memory associated with
 *  the given object instance.  This is usually invoked automatically
 *  by Itcl_ReleaseData(), when an object's data is no longer being used.
 * ------------------------------------------------------------------------
 */
static void
ItclFreeObject(cdata)
    char* cdata;  /* object instance data */
{
    ItclObject *contextObj = (ItclObject*)cdata;
    Tcl_Interp *interp = contextObj->classDefn->interp;

    int i;
    ItclClass *cdPtr;
    ItclHierIter hier;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;
    ItclVarDefn *vdefn;
    ItclContext context;
    Itcl_InterpState istate;

    /*
     *  Install the class namespace and object context so that
     *  the object's data members can be destroyed via simple
     *  "unset" commands.  This makes sure that traces work properly
     *  and all memory gets cleaned up.
     *
     *  NOTE:  Be careful to save and restore the interpreter state.
     *    Data can get freed in the middle of any operation, and
     *    we can't affort to clobber the interpreter with any errors
     *    from below.
     */
    istate = Itcl_SaveInterpState(interp, 0);

    /*
     *  Scan through all object-specific data members and destroy the
     *  actual variables that maintain the object state.  Do this
     *  by unsetting each variable, so that traces are fired off
     *  correctly.  Make sure that the built-in "this" variable is
     *  only destroyed once.  Also, be careful to activate the
     *  namespace for each class, so that private variables can
     *  be accessed.
     */
    Itcl_InitHierIter(&hier, contextObj->classDefn);
    cdPtr = Itcl_AdvanceHierIter(&hier);
    while (cdPtr != NULL) {

        if (Itcl_PushContext(interp, (ItclMember*)NULL, cdPtr,
            contextObj, &context) == TCL_OK) {

            entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
            while (entry) {
                vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
                if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
                    if (cdPtr == contextObj->classDefn) {
                        Tcl_UnsetVar2(interp, vdefn->member->fullname,
                            (char*)NULL, 0);
                    }
                }
                else if ((vdefn->member->flags & ITCL_COMMON) == 0) {
                    Tcl_UnsetVar2(interp, vdefn->member->fullname,
                        (char*)NULL, 0);
                }
                entry = Tcl_NextHashEntry(&place);
            }
            Itcl_PopContext(interp, &context);
        }

        cdPtr = Itcl_AdvanceHierIter(&hier);
    }
    Itcl_DeleteHierIter(&hier);

    /*
     *  Free the memory associated with object-specific variables.
     *  For normal variables this would be done automatically by
     *  CleanupVar() when the variable is unset.  But object-specific
     *  variables are protected by an extra reference count, and they
     *  must be deleted explicitly here.
     */
    for (i=0; i < contextObj->dataSize; i++) {
        if (contextObj->data[i]) {
            ckfree((char*)contextObj->data[i]);
        }
    }

    Itcl_RestoreInterpState(interp, istate);

    /*
     *  Free any remaining memory associated with the object.
     */
    ckfree((char*)contextObj->data);

    if (contextObj->constructed) {
        Tcl_DeleteHashTable(contextObj->constructed);
        ckfree((char*)contextObj->constructed);
    }
    if (contextObj->destructed) {
        Tcl_DeleteHashTable(contextObj->destructed);
        ckfree((char*)contextObj->destructed);
    }
    Itcl_ReleaseData((ClientData)contextObj->classDefn);

    ckfree((char*)contextObj);
}


/*
 * ------------------------------------------------------------------------
 *  ItclCreateObjVar()
 *
 *  Creates one variable acting as a data member for a specific
 *  object.  Initializes the variable according to its definition,
 *  and sets up its reference count so that it cannot be deleted
 *  by ordinary means.  Installs the new variable directly into
 *  the data array for the specified object.
 * ------------------------------------------------------------------------
 */
static void
ItclCreateObjVar(interp, vdefn, contextObj)
    Tcl_Interp* interp;       /* interpreter managing this object */
    ItclVarDefn* vdefn;       /* variable definition */
    ItclObject* contextObj;   /* object being updated */
{
    Var *varPtr;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;
    ItclContext context;

    varPtr = _TclNewVar();
    varPtr->name = vdefn->member->name;
    varPtr->nsPtr = (Namespace*)vdefn->member->classDefn->namesp;

    /*
     *  NOTE:  Tcl reports a "dangling upvar" error for variables
     *         with a null "hPtr" field.  Put something non-zero
     *         in here to keep Tcl_SetVar2() happy.  The only time
     *         this field is really used is it remove a variable
     *         from the hash table that contains it in CleanupVar,
     *         but since these variables are protected by their
     *         higher refCount, they will not be deleted by CleanupVar
     *         anyway.  These variables are unset and removed in
     *         ItclFreeObject().
     */
    varPtr->hPtr = (Tcl_HashEntry*)0x1;
    varPtr->refCount = 1;  /* protect from being deleted */

    /*
     *  Install the new variable in the object's data array.
     *  Look up the appropriate index for the object using
     *  the data table in the class definition.
     */
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars,
        vdefn->member->fullname);

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

    /*
     *  If this variable has an initial value, initialize it
     *  here using a "set" command.
     *
     *  TRICKY NOTE:  We push an object context for the class that
     *    owns the variable, so that we don't have any trouble
     *    accessing it.
     */
    if (vdefn->init) {
        if (Itcl_PushContext(interp, (ItclMember*)NULL,
            vdefn->member->classDefn, contextObj, &context) == TCL_OK) {

            Tcl_SetVar2(interp, vdefn->member->fullname,
                (char*)NULL, vdefn->init, 0);
            Itcl_PopContext(interp, &context);
        }
    }
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ScopedVarResolver()
 *
 *  This procedure is installed to handle variable resolution throughout
 *  an entire interpreter.  It looks for scoped variable references of
 *  the form:
 *
 *    @itcl ::namesp::namesp::object variable
 *
 *  If a reference like this is recognized, this procedure finds the
 *  desired variable in the object and returns the variable, along with
 *  the status code TCL_OK.  If the variable does not start with
 *  "@itcl", this procedure returns TCL_CONTINUE, and variable
 *  resolution continues using the normal rules.  If anything goes
 *  wrong, this procedure returns TCL_ERROR, and access to the
 *  variable is denied.
 * ------------------------------------------------------------------------
 */
int
Itcl_ScopedVarResolver(interp, name, contextNs, flags, rPtr)
    Tcl_Interp *interp;        /* current interpreter */
    char *name;                /* variable name being resolved */
    Tcl_Namespace *contextNs;  /* current namespace context */
    int flags;                 /* TCL_LEAVE_ERR_MSG => leave error message */
    Tcl_Var *rPtr;             /* returns: resolved variable */
{
    int namec;
    char **namev;
    Tcl_Interp *errs;
    Tcl_CmdInfo cmdInfo;
    ItclObject *contextObj;
    ItclVarLookup *vlookup;
    Tcl_HashEntry *entry;

    /*
     *  See if the variable starts with "@itcl".  If not, then
     *  let the variable resolution process continue.
     */
    if (*name != '@' || strncmp(name, "@itcl", 5) != 0) {
        return TCL_CONTINUE;
    }

    /*
     *  Break the variable name into parts and extract the object
     *  name and the variable name.
     */
    if (flags & TCL_LEAVE_ERR_MSG) {
        errs = interp;
    } else {
        errs = NULL;
    }

    if (Tcl_SplitList(errs, name, &namec, &namev) != TCL_OK) {
        return TCL_ERROR;
    }
    if (namec != 3) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "scoped variable \"", name, "\" is malformed: ",
                "should be: @itcl object variable",
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }

    /*
     *  Look for the command representing the object and extract
     *  the object context.
     */
    if (!Tcl_GetCommandInfo(interp, namev[1], &cmdInfo)) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "can't resolve scoped variable \"", name, "\": ",
                "can't find object ", namev[1],
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }
    contextObj = (ItclObject*)cmdInfo.objClientData;

    /*
     *  Resolve the variable with respect to the most-specific
     *  class definition.
     */
    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, namev[2]);
    if (!entry) {
        if (errs) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(errs),
                "can't resolve scoped variable \"", name, "\": ",
                "no such data member ", namev[2],
                (char*)NULL);
        }
        ckfree((char*)namev);
        return TCL_ERROR;
    }

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

    ckfree((char*)namev);
    return TCL_OK;
}