itcl_methods.c

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

    result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL,
        objc, objv);

    result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result);

    Itcl_ReleaseData((ClientData)mfunc);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_PushContext()
 *
 *  Sets up the class/object context so that a body of [incr Tcl]
 *  code can be executed.  This procedure pushes a call frame with
 *  the proper namespace context for the class.  If an object context
 *  is supplied, the object's instance variables are integrated into
 *  the call frame so they can be accessed as local variables.
 * ------------------------------------------------------------------------
 */
int
Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr)
    Tcl_Interp *interp;       /* interpreter managing this body of code */
    ItclMember *member;       /* member containing code body */
    ItclClass *contextClass;  /* class context */
    ItclObject *contextObj;   /* object context, or NULL */
    ItclContext *contextPtr;  /* storage space for class/object context */
{
    CallFrame *framePtr = &contextPtr->frame;

    int result, localCt, newEntry;
    ItclMemberCode *mcode;
    Proc *procPtr;
    Tcl_HashEntry *entry;

    /*
     *  Activate the call frame.  If this fails, we'll bail out
     *  before allocating any resources.
     *
     *  NOTE:  Always push a call frame that looks like a proc.
     *    This causes global variables to be handled properly
     *    inside methods/procs.
     */
    result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr,
                 contextClass->namesp, /* isProcCallFrame */ 1);

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

    contextPtr->classDefn = contextClass;
    contextPtr->compiledLocals = &contextPtr->localStorage[0];

    /*
     *  If this is an object context, register it in a hash table
     *  of all known contexts.  We'll need this later if we
     *  call Itcl_GetContext to get the object context for the
     *  current call frame.
     */
    if (contextObj) {
        entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames,
            (char*)framePtr, &newEntry);

        Itcl_PreserveData((ClientData)contextObj);
        Tcl_SetHashValue(entry, (ClientData)contextObj);
    }

    /*
     *  Set up the compiled locals in the call frame and assign
     *  argument variables.
     */
    if (member) {
        mcode = member->code;
        procPtr = mcode->procPtr;

        /*
         *  If there are too many compiled locals to fit in the default
         *  storage space for the context, then allocate more space.
         */
        localCt = procPtr->numCompiledLocals;
        if (localCt > sizeof(contextPtr->localStorage)/sizeof(Var)) {
            contextPtr->compiledLocals = (Var*)ckalloc(
                (unsigned)(localCt * sizeof(Var))
            );
        }

        /*
         * Initialize and resolve compiled variable references.
         * Class variables will have special resolution rules.
         * In that case, we call their "resolver" procs to get our
         * hands on the variable, and we make the compiled local a
         * link to the real variable.
         */

        framePtr->procPtr = procPtr;
        framePtr->numCompiledLocals = localCt;
        framePtr->compiledLocals = contextPtr->compiledLocals;

        TclInitCompiledLocals(interp, framePtr,
            (Namespace*)contextClass->namesp);
    }
    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_PopContext()
 *
 *  Removes a class/object context previously set up by Itcl_PushContext.
 *  Usually called after an [incr Tcl] code body has been executed,
 *  to clean up.
 * ------------------------------------------------------------------------
 */
void
Itcl_PopContext(interp, contextPtr)
    Tcl_Interp *interp;       /* interpreter managing this body of code */
    ItclContext *contextPtr;  /* storage space for class/object context */
{
    Tcl_CallFrame *framePtr;
    ItclObjectInfo *info;
    ItclObject *contextObj;
    Tcl_HashEntry *entry;

    /*
     *  See if the current call frame has an object context
     *  associated with it.  If so, release the claim on the
     *  object info.
     */
    framePtr = _Tcl_GetCallFrame(interp, 0);
    info = contextPtr->classDefn->info;

    entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);
    if (entry != NULL) {
        contextObj = (ItclObject*)Tcl_GetHashValue(entry);
        Itcl_ReleaseData((ClientData)contextObj);
        Tcl_DeleteHashEntry(entry);
    }

    /*
     *  Remove the call frame.
     */
    Tcl_PopCallFrame(interp);

    /*
     * Free the compiledLocals array if malloc'ed storage was used.
     */
    if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) {
        ckfree((char*)contextPtr->compiledLocals);
    }
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetContext()
 *
 *  Convenience routine for looking up the current object/class context.
 *  Useful in implementing methods/procs to see what class, and perhaps
 *  what object, is active.
 *
 *  Returns TCL_OK if the current namespace is a class namespace.
 *  Also returns pointers to the class definition, and to object
 *  data if an object context is active.  Returns TCL_ERROR (along
 *  with an error message in the interpreter) if a class namespace
 *  is not active.
 * ------------------------------------------------------------------------
 */
int
Itcl_GetContext(interp, cdefnPtr, odefnPtr)
    Tcl_Interp *interp;           /* current interpreter */
    ItclClass **cdefnPtr;         /* returns:  class definition or NULL */
    ItclObject **odefnPtr;        /* returns:  object data or NULL */
{
    Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp);
    ItclObjectInfo *info;
    Tcl_CallFrame *framePtr;
    Tcl_HashEntry *entry;

    /*
     *  Return NULL for anything that cannot be found.
     */
    *cdefnPtr = NULL;
    *odefnPtr = NULL;

    /*
     *  If the active namespace is a class namespace, then return
     *  all known info.  See if the current call frame is a known
     *  object context, and if so, return that context.
     */
    if (Itcl_IsClassNamespace(activeNs)) {
        *cdefnPtr = (ItclClass*)activeNs->clientData;

        framePtr = _Tcl_GetCallFrame(interp, 0);

        info = (*cdefnPtr)->info;
        entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr);

        if (entry != NULL) {
            *odefnPtr = (ItclObject*)Tcl_GetHashValue(entry);
        }
        return TCL_OK;
    }

    /*
     *  If there is no class/object context, return an error message.
     */
    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
        "namespace \"", activeNs->fullName, "\" is not a class namespace",
        (char*)NULL);

    return TCL_ERROR;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_AssignArgs()
 *
 *  Matches a list of arguments against a Tcl argument specification.
 *  Supports all of the rules regarding arguments for Tcl procs, including
 *  default arguments and variable-length argument lists.
 *
 *  Assumes that a local call frame is already installed.  As variables
 *  are successfully matched, they are stored as variables in the call
 *  frame.  Returns TCL_OK on success, or TCL_ERROR (along with an error
 *  message in interp->result) on error.
 * ------------------------------------------------------------------------
 */
int
Itcl_AssignArgs(interp, objc, objv, mfunc)
    Tcl_Interp *interp;        /* interpreter */
    int objc;                  /* number of arguments */
    Tcl_Obj *CONST objv[];     /* argument objects */
    ItclMemberFunc *mfunc;     /* member function info (for error messages) */
{
    ItclMemberCode *mcode = mfunc->member->code;

    int result = TCL_OK;

    int defargc;
    char **defargv = NULL;
    Tcl_Obj **defobjv = NULL;
    int configc = 0;
    ItclVarDefn **configVars = NULL;
    char **configVals = NULL;

    int vi, argsLeft;
    ItclClass *contextClass;
    ItclObject *contextObj;
    CompiledLocal *argPtr;
    CallFrame *framePtr;
    Var *varPtr;
    Tcl_Obj *objPtr, *listPtr;
    char *value;

    framePtr = (CallFrame*) _Tcl_GetCallFrame(interp, 0);
    framePtr->objc = objc;
    framePtr->objv = objv;  /* ref counts for args are incremented below */

    /*
     *  See if there is a current object context.  We may need
     *  it later on.
     */
    (void) Itcl_GetContext(interp, &contextClass, &contextObj);
    Tcl_ResetResult(interp);

    /*
     *  Match the actual arguments against the procedure's formal
     *  parameters to compute local variables.
     */
    varPtr = framePtr->compiledLocals;

    for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--;
         argsLeft > 0;
         argPtr=argPtr->nextPtr, argsLeft--, varPtr++, objv++, objc--)
    {
        if (!TclIsVarArgument(argPtr)) {
            panic("local variable %s is not argument but should be",
                argPtr->name);
            return TCL_ERROR;
        }
        if (TclIsVarTemporary(argPtr)) {
            panic("local variable is temporary but should be an argument");
            return TCL_ERROR;
        }

        /*
         *  Handle the special case of the last formal being "args".
         *  When it occurs, assign it a list consisting of all the
         *  remaining actual arguments.
         */
        if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) {
            if (objc < 0) objc = 0;

            listPtr = Tcl_NewListObj(objc, objv);
            varPtr->value.objPtr = listPtr;
            Tcl_IncrRefCount(listPtr); /* local var is a reference */
            varPtr->flags &= ~VAR_UNDEFINED;
            objc = 0;

            break;
        }

        /*
         *  Handle the special case of the last formal being "config".
         *  When it occurs, treat all remaining arguments as public
         *  variable assignments.  Set the local "config" variable
         *  to the list of public variables assigned.
         */
        else if ( (argsLeft == 1) &&
                  (strcmp(argPtr->name, "config") == 0) &&
                  contextObj )
        {
            /*
             *  If this is not an old-style method, discourage against
             *  the use of the "config" argument.
             */
            if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "\"config\" argument is an anachronism\n",
                    "[incr Tcl] no longer supports the \"config\" argument.\n",
                    "Instead, use the \"args\" argument and then use the\n",
                    "built-in configure method to handle args like this:\n",
                    "  eval configure $args",
                    (char*)NULL);
                result = TCL_ERROR;
                goto argErrors;
            }

            /*
             *  Otherwise, handle the "config" argument in the usual way...
             *   - parse all "-name value" assignments
             *   - set "config" argument to the list of variable names
             */
            if (objc > 0) {  /* still have some arguments left? */

                result = ItclParseConfig(interp, objc, objv, contextObj,
                    &configc, &configVars, &configVals);

                if (result != TCL_OK) {
                    goto argErrors;
                }

                listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
                for (vi=0; vi < configc; vi++) {
                    objPtr = Tcl_NewStringObj(
                        configVars[vi]->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);

                    Tcl_ListObjAppendElement(interp, listPtr, objPtr);
                }

                varPtr->value.objPtr = listPtr;
                Tcl_IncrRefCount(listPtr); /* local var is a reference */
                varPtr->flags &= ~VAR_UNDEFINED;

                objc = 0;  /* all remaining args handled */
            }

            else if (argPtr->defValuePtr) {
                value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL);

                result = Tcl_SplitList(interp, value, &defargc, &defargv);
                if (result != TCL_OK) {
                    goto argErrors;
                }
                defobjv = (Tcl_Obj**)ckalloc(
                    (unsigned)(defargc*sizeof(Tcl_Obj*))
                );
                for (vi=0; vi < defargc; vi++) {
                    objPtr = Tcl_NewStringObj(defargv[vi], -1);
                    Tcl_IncrRefCount(objPtr);
                    defobjv[vi] = objPtr;
                }

                result = ItclParseConfig(interp, defargc, defobjv, contextObj,
                    &configc, &configVars, &configVals);

                if (result != TCL_OK) {
                    goto argErrors;
                }

                listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
                for (vi=0; vi < configc; vi++) {
                    objPtr = Tcl_NewStringObj(
                        configVars[vi]->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1);