itcl_bicmds.c

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

     *  method was defined in a base class, the current namespace
     *  (from Itcl_ExecMethod()) will be that base class.  Activate
     *  the derived class namespace here, so that instance variables
     *  are accessed properly.
     */
    result = TCL_OK;

    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
        contextObj, &context) != TCL_OK) {
        return TCL_ERROR;
    }
    Tcl_DStringInit(&buffer);

    for (i=1; i < objc; i+=2) {
        vlookup = NULL;
        token = Tcl_GetStringFromObj(objv[i], (int*)NULL);
        if (*token == '-') {
            entry = Tcl_FindHashEntry(&contextClass->resolveVars, token+1);
            if (entry) {
                vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
            }
        }

        if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "unknown option \"", token, "\"",
                (char*)NULL);
            result = TCL_ERROR;
            goto configureDone;
        }
        if (i == objc-1) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "value for \"", token, "\" missing",
                (char*)NULL);
            result = TCL_ERROR;
            goto configureDone;
        }

        member = vlookup->vdefn->member;
        lastval = Tcl_GetVar2(interp, member->fullname, (char*)NULL, 0);
        Tcl_DStringSetLength(&buffer, 0);
        Tcl_DStringAppend(&buffer, (lastval) ? lastval : "", -1);

        token = Tcl_GetStringFromObj(objv[i+1], (int*)NULL);

        if (Tcl_SetVar2(interp, member->fullname, (char*)NULL, token,
            TCL_LEAVE_ERR_MSG) == NULL) {

            char msg[256];
            sprintf(msg, "\n    (error in configuration of public variable \"%.100s\")", member->fullname);
            Tcl_AddErrorInfo(interp, msg);
            result = TCL_ERROR;
            goto configureDone;
        }

        /*
         *  If this variable has some "config" code, invoke it now.
         *
         *  TRICKY NOTE:  Be careful to evaluate the code one level
         *    up in the call stack, so that it's executed in the
         *    calling context, and not in the context that we've
         *    set up for public variable access.
         */
        mcode = member->code;
        if (mcode && mcode->procPtr->bodyPtr) {

            uplevelFramePtr = _Tcl_GetCallFrame(interp, 1);
            oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr);

            result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL,
                member, contextObj, 0, (Tcl_Obj**)NULL);

            (void) _Tcl_ActivateCallFrame(interp, oldFramePtr);

            if (result == TCL_OK) {
                Tcl_ResetResult(interp);
            } else {
                char msg[256];
                sprintf(msg, "\n    (error in configuration of public variable \"%.100s\")", member->fullname);
                Tcl_AddErrorInfo(interp, msg);

                Tcl_SetVar2(interp, member->fullname,(char*)NULL,
                    Tcl_DStringValue(&buffer), 0);

                goto configureDone;
            }
        }
    }

configureDone:
    Itcl_PopContext(interp, &context);
    Tcl_DStringFree(&buffer);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiCgetCmd()
 *
 *  Invoked whenever the user issues the "cget" method for an object.
 *  Handles the following syntax:
 *
 *    <objName> cget -<option>
 *
 *  Allows access to public variables as if they were configuration
 *  options.  Mimics the behavior of the usual "cget" method for
 *  Tk widgets.  Returns the current value of the public variable
 *  with name <option>.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiCgetCmd(clientData, interp, objc, objv)
    ClientData clientData;   /* class definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclClass *contextClass;
    ItclObject *contextObj;

    char *name, *val;
    ItclVarLookup *vlookup;
    Tcl_HashEntry *entry;

    /*
     *  Make sure that this command is being invoked in the proper
     *  context.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }
    if (!contextObj || objc != 2) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "improper usage: should be \"object cget -option\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  BE CAREFUL:  work in the virtual scope!
     */
    contextClass = contextObj->classDefn;

    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    vlookup = NULL;
    entry = Tcl_FindHashEntry(&contextClass->resolveVars, name+1);
    if (entry) {
        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
    }

    if (!vlookup || vlookup->vdefn->member->protection != ITCL_PUBLIC) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "unknown option \"", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    val = Itcl_GetInstanceVar(interp, vlookup->vdefn->member->fullname,
        contextObj, contextObj->classDefn);

    if (val) {
        Tcl_SetResult(interp, val, TCL_VOLATILE);
    } else {
        Tcl_SetResult(interp, "<undefined>", TCL_STATIC);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclReportPublicOpt()
 *
 *  Returns information about a public variable formatted as a
 *  configuration option:
 *
 *    -<varName> <initVal> <currentVal>
 *
 *  Used by Itcl_BiConfigureCmd() to report configuration options.
 *  Returns a Tcl_Obj containing the information.
 * ------------------------------------------------------------------------
 */
static Tcl_Obj*
ItclReportPublicOpt(interp, vdefn, contextObj)
    Tcl_Interp *interp;      /* interpreter containing the object */
    ItclVarDefn *vdefn;      /* public variable to be reported */
    ItclObject *contextObj;  /* object containing this variable */
{
    char *val;
    ItclClass *cdefnPtr;
    Tcl_HashEntry *entry;
    ItclVarLookup *vlookup;
    Tcl_DString optName;
    Tcl_Obj *listPtr, *objPtr;

    listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);

    /*
     *  Determine how the option name should be reported.
     *  If the simple name can be used to find it in the virtual
     *  data table, then use the simple name.  Otherwise, this
     *  is a shadowed variable; use the full name.
     */
    Tcl_DStringInit(&optName);
    Tcl_DStringAppend(&optName, "-", -1);

    cdefnPtr = (ItclClass*)contextObj->classDefn;
    entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, vdefn->member->fullname);
    assert(entry != NULL);
    vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
    Tcl_DStringAppend(&optName, vlookup->leastQualName, -1);

    objPtr = Tcl_NewStringObj(Tcl_DStringValue(&optName), -1);
    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);
    Tcl_DStringFree(&optName);


    if (vdefn->init) {
        objPtr = Tcl_NewStringObj(vdefn->init, -1);
    } else {
        objPtr = Tcl_NewStringObj("<undefined>", -1);
    }
    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);

    val = Itcl_GetInstanceVar(interp, vdefn->member->fullname, contextObj,
        contextObj->classDefn);

    if (val) {
        objPtr = Tcl_NewStringObj(val, -1);
    } else {
        objPtr = Tcl_NewStringObj("<undefined>", -1);
    }
    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objPtr);

    return listPtr;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiChainCmd()
 *
 *  Invoked to handle the "chain" command, to access the version of
 *  a method or proc that exists in a base class.  Handles the
 *  following syntax:
 *
 *    chain ?<arg> <arg>...?
 *
 *  Looks up the inheritance hierarchy for another implementation
 *  of the method/proc that is currently executing.  If another
 *  implementation is found, it is invoked with the specified
 *  <arg> arguments.  If it is not found, this command does nothing.
 *  This allows a base class method to be called out in a generic way,
 *  so the code will not have to change if the base class changes.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiChainCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* not used */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    int result = TCL_OK;

    ItclClass *contextClass;
    ItclObject *contextObj;

    char *cmd, *head;
    ItclClass *cdefn;
    ItclHierIter hier;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;
    Tcl_DString buffer;
    CallFrame *framePtr;
    Tcl_Obj *cmdlinePtr, **newobjv;

    /*
     *  If this command is not invoked within a class namespace,
     *  signal an error.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot chain functions outside of a class context",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Try to get the command name from the current call frame.
     *  If it cannot be determined, do nothing.  Otherwise, trim
     *  off any leading path names.
     */
    framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
    if (!framePtr || !framePtr->objv) {
        return TCL_OK;
    }
    cmd = Tcl_GetStringFromObj(framePtr->objv[0], (int*)NULL);
    Itcl_ParseNamespPath(cmd, &buffer, &head, &cmd);

    /*
     *  Look for the specified command in one of the base classes.
     *  If we have an object context, then start from the most-specific
     *  class and walk up the hierarchy to the current context.  If
     *  there is multiple inheritance, having the entire inheritance
     *  hierarchy will allow us to jump over to another branch of
     *  the inheritance tree.
     *
     *  If there is no object context, just start with the current
     *  class context.
     */
    if (contextObj) {
        Itcl_InitHierIter(&hier, contextObj->classDefn);
        while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
            if (cdefn == contextClass) {
                break;
            }
        }
    }
    else {
        Itcl_InitHierIter(&hier, contextClass);
        Itcl_AdvanceHierIter(&hier);    /* skip the current class */
    }

    /*
     *  Now search up the class hierarchy for the next implementation.
     *  If found, execute it.  Otherwise, do nothing.
     */
    while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
        entry = Tcl_FindHashEntry(&cdefn->functions, cmd);
        if (entry) {
            mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);

            /*
             *  NOTE:  Avoid the usual "virtual" behavior of
             *         methods by passing the full name as
             *         the command argument.
             */
            cmdlinePtr = Itcl_CreateArgs(interp, mfunc->member->fullname,
                objc-1, objv+1);

            (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr,
                &objc, &newobjv);

            result = Itcl_EvalArgs(interp, objc, newobjv);

            Tcl_DecrRefCount(cmdlinePtr);
            break;
        }
    }

    Tcl_DStringFree(&buffer);
    Itcl_DeleteHierIter(&hier);
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiInfoClassCmd()
 *
 *  Returns information regarding the class for an object.  This command
 *  can be invoked with or without an object context:
 *
 *    <objName> info class   <= returns most-specific class name
 *    info class             <= returns active namespace name
 *
 *  Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiInfoClassCmd(dummy, interp, objc, objv)
    ClientData dummy;     /* not used */
    Tcl_Interp *interp;   /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
    Tcl_Namespace *contextNs = NULL;

    ItclClass *contextClass;
    ItclObject *contextObj;

    char *name;

    if (objc != 1) {
        Tcl_WrongNumArgs(interp, 1, objv, NULL);
        return TCL_ERROR;
    }

    /*
     *  If this command is not invoked within a class namespace,
     *  signal an error.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\nget info like this instead: ",
            "\n  namespace eval className { info ", name, "... }",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If there is an object context, then return the most-specific
     *  class for the object.  Otherwise, return the class namespace
     *  name.  Use normal class names when possible.
     */
    if (contextObj) {
        contextNs = contextObj->classDefn->namesp;
    } else {
      assert(contextClass != NULL);
      assert(contextClass->namesp != NULL);
      contextNs = contextClass->namesp;
    }

    if (contextNs->parentPtr == activeNs) {