itcl_objects.c

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

/*
 * ------------------------------------------------------------------------
 *  ItclDestructBase()
 *
 *  Invoked by Itcl_DestructObject() to recursively destruct an object
 *  from the specified class level.  Finds and invokes the destructor
 *  for the specified class, and then recursively destructs all base
 *  classes.  If the ITCL_IGNORE_ERRS flag is included, all destructors
 *  are invoked even if errors are encountered, and the result will
 *  always be TCL_OK.
 *
 *  Returns TCL_OK on success, or TCL_ERROR (along with an error message
 *  in interp->result) on error.
 * ------------------------------------------------------------------------
 */
static int
ItclDestructBase(interp, contextObj, contextClass, flags)
    Tcl_Interp *interp;       /* interpreter */
    ItclObject *contextObj;   /* object being destructed */
    ItclClass *contextClass;  /* current class being destructed */
    int flags;                /* flags: ITCL_IGNORE_ERRS */
{
    int result;
    Itcl_ListElem *elem;
    ItclClass *cdefn;

    /*
     *  Look for a destructor in this class, and if found,
     *  invoke it.
     */
    if (!Tcl_FindHashEntry(contextObj->destructed, contextClass->name)) {

        result = Itcl_InvokeMethodIfExists(interp, "destructor",
            contextClass, contextObj, 0, (Tcl_Obj* CONST*)NULL);

        if (result != TCL_OK) {
            return TCL_ERROR;
        }
    }

    /*
     *  Scan through the list of base classes recursively and destruct
     *  them.  Traverse the list in normal order, so that we destruct
     *  from most- to least-specific.
     */
    elem = Itcl_FirstListElem(&contextClass->bases);
    while (elem) {
        cdefn = (ItclClass*)Itcl_GetListValue(elem);

        if (ItclDestructBase(interp, contextObj, cdefn, flags) != TCL_OK) {
            return TCL_ERROR;
        }
        elem = Itcl_NextListElem(elem);
    }

    /*
     *  Throw away any result from the destructors and return.
     */
    Tcl_ResetResult(interp);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_FindObject()
 *
 *  Searches for an object with the specified name, which have
 *  namespace scope qualifiers like "namesp::namesp::name", or may
 *  be a scoped value such as "namespace inscope ::foo obj".
 *
 *  If an error is encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK.  If an object was found, "roPtr" returns a
 *  pointer to the object data.  Otherwise, it returns NULL.
 * ------------------------------------------------------------------------
 */
int
Itcl_FindObject(interp, name, roPtr)
    Tcl_Interp *interp;      /* interpreter containing this object */
    char *name;              /* name of the object */
    ItclObject **roPtr;      /* returns: object data or NULL */
{
    Tcl_Namespace *contextNs = NULL;

    char *cmdName;
    Tcl_Command cmd;
    Command *cmdPtr;

    /*
     *  The object name may be a scoped value of the form
     *  "namespace inscope <namesp> <command>".  If it is,
     *  decode it.
     */
    if (Itcl_DecodeScopedCommand(interp, name, &contextNs, &cmdName)
        != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Look for the object's access command, and see if it has
     *  the appropriate command handler.
     */
    cmd = Tcl_FindCommand(interp, cmdName, contextNs, /* flags */ 0);
    if (cmd != NULL && Itcl_IsObject(cmd)) {
        cmdPtr = (Command*)cmd;
        *roPtr = (ItclObject*)cmdPtr->objClientData;
    }
    else {
        *roPtr = NULL;
    }

    if (cmdName != name) {
        ckfree(cmdName);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_IsObject()
 *
 *  Checks the given Tcl command to see if it represents an itcl object.
 *  Returns non-zero if the command is associated with an object.
 * ------------------------------------------------------------------------
 */
int
Itcl_IsObject(cmd)
    Tcl_Command cmd;         /* command being tested */
{
    Command *cmdPtr = (Command*)cmd;

    if (cmdPtr->deleteProc == ItclDestroyObject) {
        return 1;
    }

    /*
     *  This may be an imported command.  Try to get the real
     *  command and see if it represents an object.
     */
    cmdPtr = (Command*)TclGetOriginalCommand(cmd);
    if (cmdPtr && cmdPtr->deleteProc == ItclDestroyObject) {
        return 1;
    }
    return 0;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ObjectIsa()
 *
 *  Checks to see if an object belongs to the given class.  An object
 *  "is-a" member of the class if the class appears anywhere in its
 *  inheritance hierarchy.  Returns non-zero if the object belongs to
 *  the class, and zero otherwise.
 * ------------------------------------------------------------------------
 */
int
Itcl_ObjectIsa(contextObj, cdefn)
    ItclObject *contextObj;   /* object being tested */
    ItclClass *cdefn;         /* class to test for "is-a" relationship */
{
    Tcl_HashEntry *entry;
    entry = Tcl_FindHashEntry(&contextObj->classDefn->heritage, (char*)cdefn);
    return (entry != NULL);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_HandleInstance()
 *
 *  Invoked by Tcl whenever the user issues a command associated with
 *  an object instance.  Handles the following syntax:
 *
 *    <objName> <method> <args>...
 *
 * ------------------------------------------------------------------------
 */
int
Itcl_HandleInstance(clientData, interp, objc, objv)
    ClientData clientData;   /* object definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclObject *contextObj = (ItclObject*)clientData;

    int result;
    char *token;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;
    ItclObjectInfo *info;
    ItclContext context;
    CallFrame *framePtr;

    if (objc < 2) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "wrong # args: should be one of...",
            (char*)NULL);
        ItclReportObjectUsage(interp, contextObj);
        return TCL_ERROR;
    }

    /*
     *  Make sure that the specified operation is really an
     *  object method, and it is accessible.  If not, return usage
     *  information for the object.
     */
    token = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    mfunc = NULL;

    entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, token);
    if (entry) {
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);

        if ((mfunc->member->flags & ITCL_COMMON) != 0) {
            mfunc = NULL;
        }
        else if (mfunc->member->protection != ITCL_PUBLIC) {
            Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
                mfunc->member->classDefn->info);

            if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
                mfunc = NULL;
            }
        }
    }

    if ( !mfunc && (*token != 'i' || strcmp(token,"info") != 0) ) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "bad option \"", token, "\": should be one of...",
            (char*)NULL);
        ItclReportObjectUsage(interp, contextObj);
        return TCL_ERROR;
    }

    /*
     *  Install an object context and invoke the method.
     *
     *  TRICKY NOTE:  We need to pass the object context into the
     *    method, but activating the context here puts us one level
     *    down, and when the method is called, it will activate its
     *    own context, putting us another level down.  If anyone
     *    were to execute an "uplevel" command in the method, they
     *    would notice the extra call frame.  So we mark this frame
     *    as "transparent" and Itcl_EvalMemberCode will automatically
     *    do an "uplevel" operation to correct the problem.
     */
    info = contextObj->classDefn->info;

    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
        contextObj, &context) != TCL_OK) {

        return TCL_ERROR;
    }

    framePtr = &context.frame;
    Itcl_PushStack((ClientData)framePtr, &info->transparentFrames);

    result = Itcl_EvalArgs(interp, objc-1, objv+1);

    Itcl_PopStack(&info->transparentFrames);
    Itcl_PopContext(interp, &context);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetInstanceVar()
 *
 *  Returns the current value for an object data member.  The member
 *  name is interpreted with respect to the given class scope, which
 *  is usually the most-specific class for the object.
 *
 *  If successful, this procedure returns a pointer to a string value
 *  which remains alive until the variable changes it value.  If
 *  anything goes wrong, this returns NULL.
 * ------------------------------------------------------------------------
 */
char*
Itcl_GetInstanceVar(interp, name, contextObj, contextClass)
    Tcl_Interp *interp;       /* current interpreter */
    char *name;               /* name of desired instance variable */
    ItclObject *contextObj;   /* current object */
    ItclClass *contextClass;  /* name is interpreted in this scope */
{
    ItclContext context;
    char *val;

    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.
     */
    if (contextObj == NULL) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            (char*)NULL);
        return NULL;
    }

    /*
     *  Install the object context and access the data member
     *  like any other variable.
     */
    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextClass,
        contextObj, &context) != TCL_OK) {

        return NULL;
    }

    val = Tcl_GetVar2(interp, name, (char*)NULL, TCL_LEAVE_ERR_MSG);
    Itcl_PopContext(interp, &context);

    return val;
}


/*
 * ------------------------------------------------------------------------
 *  ItclReportObjectUsage()
 *
 *  Appends information to the given interp summarizing the usage
 *  for all of the methods available for this object.  Useful when
 *  reporting errors in Itcl_HandleInstance().
 * ------------------------------------------------------------------------
 */
static void
ItclReportObjectUsage(interp, contextObj)
    Tcl_Interp *interp;      /* current interpreter */
    ItclObject *contextObj;  /* current object */
{
    ItclClass *cdefnPtr = (ItclClass*)contextObj->classDefn;
    int ignore = ITCL_CONSTRUCTOR | ITCL_DESTRUCTOR | ITCL_COMMON;

    int cmp;
    char *name;
    Itcl_List cmdList;
    Itcl_ListElem *elem;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    ItclMemberFunc *mfunc, *cmpDefn;
    Tcl_Obj *resultPtr;

    /*
     *  Scan through all methods in the virtual table and sort
     *  them in alphabetical order.  Report only the methods
     *  that have simple names (no ::'s) and are accessible.
     */
    Itcl_InitList(&cmdList);
    entry = Tcl_FirstHashEntry(&cdefnPtr->resolveCmds, &place);
    while (entry) {
        name  = Tcl_GetHashKey(&cdefnPtr->resolveCmds, entry);
        mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);

        if (strstr(name,"::") || (mfunc->member->flags & ignore) != 0) {
            mfunc = NULL;
        }
        else if (mfunc->member->protection != ITCL_PUBLIC) {
            Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
                mfunc->member->classDefn->info);

            if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
                mfunc = NULL;
            }
        }

        if (mfunc) {
            elem = Itcl_FirstListElem(&cmdList);
            while (elem) {
                cmpDefn = (ItclMemberFunc*)Itcl_GetListValue(elem);
                cmp = strcmp(mfunc->member->name, cmpDefn->member->name);
                if (cmp < 0) {
                    Itcl_InsertListElem(elem, (ClientData)mfunc);
                    mfunc = NULL;
                    break;
                }
                else if (cmp == 0) {
                    mfunc = NULL;
                    break;
                }
                elem = Itcl_NextListElem(elem);
            }
            if (mfunc) {
                Itcl_AppendList(&cmdList, (ClientData)mfunc);
            }
        }
        entry = Tcl_NextHashEntry(&place);
    }

    /*
     *  Add a series of statements showing usage info.
     */
    resultPtr = Tcl_GetObjResult(interp);
    elem = Itcl_FirstListElem(&cmdList);
    while (elem) {
        mfunc = (ItclMemberFunc*)Itcl_GetListValue(elem);
        Tcl_AppendToObj(resultPtr, "\n  ", -1);
        Itcl_GetMemberFuncUsage(mfunc, contextObj, resultPtr);