itcl_methods.c

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

 * ------------------------------------------------------------------------
 *  Itcl_DeleteArgList()
 *
 *  Destroys a chain of arguments acting as an argument list.  Usually
 *  invoked when a method/proc is being destroyed, to discard its
 *  argument list.
 * ------------------------------------------------------------------------
 */
void
Itcl_DeleteArgList(arglist)
    CompiledLocal *arglist;   /* first argument in arg list chain */
{
    CompiledLocal *localPtr, *next;

    for (localPtr=arglist; localPtr; localPtr=next) {
        if (localPtr->defValuePtr != NULL) {
            Tcl_DecrRefCount(localPtr->defValuePtr);
        }
        if (localPtr->resolveInfo) {
            if (localPtr->resolveInfo->deleteProc) {
                localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
            } else {
                ckfree((char*)localPtr->resolveInfo);
            }
            localPtr->resolveInfo = NULL;
        }
        next = localPtr->nextPtr;
        ckfree((char*)localPtr);
    }
}

/*
 * ------------------------------------------------------------------------
 *  Itcl_ArgList()
 *
 *  Returns a Tcl_Obj containing the string representation for the
 *  given argument list.  This object has a reference count of 1.
 *  The reference count should be decremented when the string is no
 *  longer needed, and it will free itself.
 * ------------------------------------------------------------------------
 */
Tcl_Obj*
Itcl_ArgList(argc, arglist)
    int argc;                   /* number of arguments */
    CompiledLocal* arglist;     /* first argument in arglist */
{
    char *val;
    Tcl_Obj *objPtr;
    Tcl_DString buffer;

    Tcl_DStringInit(&buffer);

    while (arglist && argc-- > 0) {
        if (arglist->defValuePtr) {
            val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL);
            Tcl_DStringStartSublist(&buffer);
            Tcl_DStringAppendElement(&buffer, arglist->name);
            Tcl_DStringAppendElement(&buffer, val);
            Tcl_DStringEndSublist(&buffer);
        }
        else {
            Tcl_DStringAppendElement(&buffer, arglist->name);
        }
        arglist = arglist->nextPtr;
    }

    objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
        Tcl_DStringLength(&buffer));

    Tcl_DStringFree(&buffer);

    return objPtr;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_EquivArgLists()
 *
 *  Compares two argument lists to see if they are equivalent.  The
 *  first list is treated as a prototype, and the second list must
 *  match it.  Argument names may be different, but they must match in
 *  meaning.  If one argument is optional, the corresponding argument
 *  must also be optional.  If the prototype list ends with the magic
 *  "args" argument, then it matches everything in the other list.
 *
 *  Returns non-zero if the argument lists are equivalent.
 * ------------------------------------------------------------------------
 */
int
Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c)
    CompiledLocal* arg1;   /* prototype argument list */
    int arg1c;             /* number of args in prototype arg list */
    CompiledLocal* arg2;   /* another argument list to match against */
    int arg2c;             /* number of args in matching list */
{
    char *dval1, *dval2;

    while (arg1 && arg1c > 0 && arg2 && arg2c > 0) {
        /*
         *  If the prototype argument list ends with the magic "args"
         *  argument, then it matches everything in the other list.
         */
        if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
            return 1;
        }

        /*
         *  If one has a default value, then the other must have the
         *  same default value.
         */
        if (arg1->defValuePtr) {
            if (arg2->defValuePtr == NULL) {
                return 0;
            }

            dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL);
            dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL);
            if (strcmp(dval1, dval2) != 0) {
                return 0;
            }
        }
        else if (arg2->defValuePtr) {
            return 0;
        }

        arg1 = arg1->nextPtr;  arg1c--;
        arg2 = arg2->nextPtr;  arg2c--;
    }
    if (arg1c == 1 && strcmp(arg1->name,"args") == 0) {
        return 1;
    }
    return (arg1c == 0 && arg2c == 0);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetMemberFuncUsage()
 *
 *  Returns a string showing how a command member should be invoked.
 *  If the command member is a method, then the specified object name
 *  is reported as part of the invocation path:
 *
 *      obj method arg ?arg arg ...?
 *
 *  Otherwise, the "obj" pointer is ignored, and the class name is
 *  used as the invocation path:
 *
 *      class::proc arg ?arg arg ...?
 *
 *  Returns the string by appending it onto the Tcl_Obj passed in as
 *  an argument.
 * ------------------------------------------------------------------------
 */
void
Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr)
    ItclMemberFunc *mfunc;      /* command member being examined */
    ItclObject *contextObj;     /* invoked with respect to this object */
    Tcl_Obj *objPtr;            /* returns: string showing usage */
{
    int argcount;
    char *name;
    CompiledLocal *arglist, *argPtr;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mf;
    ItclClass *cdefnPtr;

    /*
     *  If the command is a method and an object context was
     *  specified, then add the object context.  If the method
     *  was a constructor, and if the object is being created,
     *  then report the invocation via the class creation command.
     */
    if ((mfunc->member->flags & ITCL_COMMON) == 0) {
        if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 &&
            contextObj->constructed) {

            cdefnPtr = (ItclClass*)contextObj->classDefn;
            mf = NULL;
            entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor");
            if (entry) {
                mf = (ItclMemberFunc*)Tcl_GetHashValue(entry);
            }

            if (mf == mfunc) {
                Tcl_GetCommandFullName(contextObj->classDefn->interp,
                    contextObj->classDefn->accessCmd, objPtr);
                Tcl_AppendToObj(objPtr, " ", -1);
                name = Tcl_GetCommandName(contextObj->classDefn->interp,
                    contextObj->accessCmd);
                Tcl_AppendToObj(objPtr, name, -1);
            } else {
                Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
            }
        }
        else if (contextObj && contextObj->accessCmd) {
            name = Tcl_GetCommandName(contextObj->classDefn->interp,
                contextObj->accessCmd);
            Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name,
                (char*)NULL);
        }
        else {
            Tcl_AppendStringsToObj(objPtr, "<object> ", mfunc->member->name,
                (char*)NULL);
        }
    }
    else {
        Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1);
    }

    /*
     *  Add the argument usage info.
     */
    if (mfunc->member->code) {
        arglist = mfunc->member->code->arglist;
        argcount = mfunc->member->code->argcount;
    } else if (mfunc->arglist) {
        arglist = mfunc->arglist;
        argcount = mfunc->argcount;
    } else {
        arglist = NULL;
        argcount = 0;
    }

    if (arglist) {
        for (argPtr=arglist;
             argPtr && argcount > 0;
             argPtr=argPtr->nextPtr, argcount--) {

            if (argcount == 1 && strcmp(argPtr->name, "args") == 0) {
                Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1);
            }
            else if (argPtr->defValuePtr) {
                Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?",
                    (char*)NULL);
            }
            else {
                Tcl_AppendStringsToObj(objPtr, " ", argPtr->name,
                    (char*)NULL);
            }
        }
    }
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ExecMethod()
 *
 *  Invoked by Tcl to handle the execution of a user-defined method.
 *  A method is similar to the usual Tcl proc, but has access to
 *  object-specific data.  If for some reason there is no current
 *  object context, then a method call is inappropriate, and an error
 *  is returned.
 *
 *  Methods are implemented either as Tcl code fragments, or as C-coded
 *  procedures.  For Tcl code fragments, command arguments are parsed
 *  according to the argument list, and the body is executed in the
 *  scope of the class where it was defined.  For C procedures, the
 *  arguments are passed in "as-is", and the procedure is executed in
 *  the most-specific class scope.
 * ------------------------------------------------------------------------
 */
int
Itcl_ExecMethod(clientData, interp, objc, objv)
    ClientData clientData;   /* method definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
    ItclMember *member = mfunc->member;
    int result = TCL_OK;

    char *token;
    Tcl_HashEntry *entry;
    ItclClass *contextClass;
    ItclObject *contextObj;

    /*
     *  Make sure that the current namespace context includes an
     *  object that is being manipulated.  Methods can be executed
     *  only if an object context exists.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }
    if (contextObj == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot access object-specific info without an object context",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Make sure that this command member can be accessed from
     *  the current namespace context.
     */
    if (mfunc->member->protection != ITCL_PUBLIC) {
        Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
            contextClass->info);

        if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "can't access \"", member->fullname, "\": ",
                Itcl_ProtectionStr(member->protection), " function",
                (char*)NULL);
            return TCL_ERROR;
        }
    }

    /*
     *  All methods should be "virtual" unless they are invoked with
     *  a "::" scope qualifier.
     *
     *  To implement the "virtual" behavior, find the most-specific
     *  implementation for the method by looking in the "resolveCmds"
     *  table for this class.
     */
    token = Tcl_GetStringFromObj(objv[0], (int*)NULL);
    if (strstr(token, "::") == NULL) {
        entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds,
            member->name);

        if (entry) {
            mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
            member = mfunc->member;
        }
    }

    /*
     *  Execute the code for the method.  Be careful to protect
     *  the method in case it gets deleted during execution.
     */
    Itcl_PreserveData((ClientData)mfunc);

    result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
        objc, objv);

    result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);

    Itcl_ReleaseData((ClientData)mfunc);

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ExecProc()
 *
 *  Invoked by Tcl to handle the execution of a user-defined proc.
 *
 *  Procs are implemented either as Tcl code fragments, or as C-coded
 *  procedures.  For Tcl code fragments, command arguments are parsed
 *  according to the argument list, and the body is executed in the
 *  scope of the class where it was defined.  For C procedures, the
 *  arguments are passed in "as-is", and the procedure is executed in
 *  the most-specific class scope.
 * ------------------------------------------------------------------------
 */
int
Itcl_ExecProc(clientData, interp, objc, objv)
    ClientData clientData;   /* proc definition */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData;
    ItclMember *member = mfunc->member;
    int result = TCL_OK;

    /*
     *  Make sure that this command member can be accessed from
     *  the current namespace context.
     */
    if (mfunc->member->protection != ITCL_PUBLIC) {
        Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
            mfunc->member->classDefn->info);

        if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "can't access \"", member->fullname, "\": ",
                Itcl_ProtectionStr(member->protection), " function",
                (char*)NULL);
            return TCL_ERROR;
        }
    }

    /*
     *  Execute the code for the proc.  Be careful to protect
     *  the proc in case it gets deleted during execution.
     */
    Itcl_PreserveData((ClientData)mfunc);