itcl_methods.c

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

    Tcl_DStringAppend(&buffer, name, -1);
    name = Tcl_DStringValue(&buffer);

    Itcl_PreserveData((ClientData)mfunc);
    mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecProc,
        (ClientData)mfunc, Itcl_ReleaseData);

    Tcl_DStringFree(&buffer);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateMemberFunc()
 *
 *  Creates the data record representing a member function.  This
 *  includes the argument list and the body of the function.  If the
 *  body is of the form "@name", then it is treated as a label for
 *  a C procedure registered by Itcl_RegisterC().
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "mfuncPtr" returns a pointer to the new
 *  member function.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr)
    Tcl_Interp* interp;            /* interpreter managing this action */
    ItclClass *cdefn;              /* class definition */
    char* name;                    /* name of new member */
    char* arglist;                 /* space-separated list of arg names */
    char* body;                    /* body of commands for the method */
    ItclMemberFunc** mfuncPtr;     /* returns: pointer to new method defn */
{
    int newEntry;
    ItclMemberFunc *mfunc;
    ItclMemberCode *mcode;
    Tcl_HashEntry *entry;

    /*
     *  Add the member function to the list of functions for
     *  the class.  Make sure that a member function with the
     *  same name doesn't already exist.
     */
    entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry);

    if (!newEntry) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" already defined in class \"",
            cdefn->fullname, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Try to create the implementation for this command member.
     */
    if (Itcl_CreateMemberCode(interp, cdefn, arglist, body,
        &mcode) != TCL_OK) {

        Tcl_DeleteHashEntry(entry);
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)mcode);
    Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);

    /*
     *  Allocate a member function definition and return.
     */
    mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc));
    mfunc->member = Itcl_CreateMember(interp, cdefn, name);
    mfunc->member->code = mcode;

    if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) {
        mfunc->member->protection = ITCL_PUBLIC;
    }

    mfunc->arglist   = NULL;
    mfunc->argcount  = 0;
    mfunc->accessCmd = NULL;

    if (arglist) {
        mfunc->member->flags |= ITCL_ARG_SPEC;
    }
    if (mcode->arglist) {
        Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist);
    }

    if (strcmp(name,"constructor") == 0) {
        mfunc->member->flags |= ITCL_CONSTRUCTOR;
    }
    if (strcmp(name,"destructor") == 0) {
        mfunc->member->flags |= ITCL_DESTRUCTOR;
    }

    Tcl_SetHashValue(entry, (ClientData)mfunc);
    Itcl_PreserveData((ClientData)mfunc);
    Itcl_EventuallyFree((ClientData)mfunc, Itcl_DeleteMemberFunc);

    *mfuncPtr = mfunc;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_ChangeMemberFunc()
 *
 *  Modifies the data record representing a member function.  This
 *  is usually the body of the function, but can include the argument
 *  list if it was not defined when the member was first created.
 *  If the body is of the form "@name", then it is treated as a label
 *  for a C procedure registered by Itcl_RegisterC().
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "mfuncPtr" returns a pointer to the new
 *  member function.
 * ------------------------------------------------------------------------
 */
int
Itcl_ChangeMemberFunc(interp, mfunc, arglist, body)
    Tcl_Interp* interp;            /* interpreter managing this action */
    ItclMemberFunc* mfunc;         /* command member being changed */
    char* arglist;                 /* space-separated list of arg names */
    char* body;                    /* body of commands for the method */
{
    ItclMemberCode *mcode = NULL;
    Tcl_Obj *objPtr;

    /*
     *  Try to create the implementation for this command member.
     */
    if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn,
        arglist, body, &mcode) != TCL_OK) {

        return TCL_ERROR;
    }

    /*
     *  If the argument list was defined when the function was
     *  created, compare the arg lists or usage strings to make sure
     *  that the interface is not being redefined.
     */
    if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 &&
        !Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount,
            mcode->arglist, mcode->argcount)) {

        objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
        Tcl_IncrRefCount(objPtr);

        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "argument list changed for function \"",
            mfunc->member->fullname, "\": should be \"",
            Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"",
            (char*)NULL);
        Tcl_DecrRefCount(objPtr);

        Itcl_DeleteMemberCode((char*)mcode);
        return TCL_ERROR;
    }

    /*
     *  Free up the old implementation and install the new one.
     */
    Itcl_PreserveData((ClientData)mcode);
    Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode);

    Itcl_ReleaseData((ClientData)mfunc->member->code);
    mfunc->member->code = mcode;

    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteMemberFunc()
 *
 *  Destroys all data associated with the given member function definition.
 *  Usually invoked by the interpreter when a member function is deleted.
 * ------------------------------------------------------------------------
 */
void
Itcl_DeleteMemberFunc(cdata)
    char* cdata;  /* pointer to member function definition */
{
    ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata;

    if (mfunc) {
        Itcl_DeleteMember(mfunc->member);

        if (mfunc->arglist) {
            Itcl_DeleteArgList(mfunc->arglist);
        }
        ckfree((char*)mfunc);
    }
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_CreateMemberCode()
 *
 *  Creates the data record representing the implementation behind a
 *  class member function.  This includes the argument list and the body
 *  of the function.  If the body is of the form "@name", then it is
 *  treated as a label for a C procedure registered by Itcl_RegisterC().
 *
 *  The implementation is kept by the member function definition, and
 *  controlled by a preserve/release paradigm.  That way, if it is in
 *  use while it is being redefined, it will stay around long enough
 *  to avoid a core dump.
 *
 *  If any errors are encountered, this procedure returns TCL_ERROR
 *  along with an error message in the interpreter.  Otherwise, it
 *  returns TCL_OK, and "mcodePtr" returns a pointer to the new
 *  implementation.
 * ------------------------------------------------------------------------
 */
int
Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr)
    Tcl_Interp* interp;            /* interpreter managing this action */
    ItclClass *cdefn;              /* class containing this member */
    char* arglist;                 /* space-separated list of arg names */
    char* body;                    /* body of commands for the method */
    ItclMemberCode** mcodePtr;     /* returns: pointer to new implementation */
{
    int argc;
    CompiledLocal *args, *localPtr;
    ItclMemberCode *mcode;
    Proc *procPtr;

    /*
     *  Allocate some space to hold the implementation.
     */
    mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode));
    mcode->flags        = 0;
    mcode->argcount     = 0;
    mcode->arglist      = NULL;
    mcode->procPtr      = NULL;
    mcode->cfunc.objCmd = NULL;
    mcode->clientData   = NULL;

    if (arglist) {
        if (Itcl_CreateArgList(interp, arglist, &argc, &args)
            != TCL_OK) {

            Itcl_DeleteMemberCode((char*)mcode);
            return TCL_ERROR;
        }
        mcode->argcount = argc;
        mcode->arglist  = args;
        mcode->flags   |= ITCL_ARG_SPEC;
    } else {
        argc = 0;
        args = NULL;
    }

    /*
     *  Create a standard Tcl Proc representation for this code body.
     *  This is required, since the Tcl compiler looks for a proc
     *  when handling things such as the call frame context and
     *  compiled locals.
     */
    procPtr = (Proc*)ckalloc(sizeof(Proc));
    mcode->procPtr = procPtr;

    procPtr->iPtr = (Interp*)interp;
    procPtr->refCount = 1;
    procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command));
    procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp;

    if (body) {
        procPtr->bodyPtr = Tcl_NewStringObj(body, -1);
        Tcl_IncrRefCount(procPtr->bodyPtr);
    } else {
        procPtr->bodyPtr = NULL;
    }

    /*
     *  Plug the argument list into the "compiled locals" list.
     *
     *  NOTE:  The storage for this argument list is owned by
     *    the caller, so although we plug it in here, it is not
     *    our responsibility to free it.
     */
    procPtr->firstLocalPtr = args;
    procPtr->lastLocalPtr = NULL;

    for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) {
        procPtr->lastLocalPtr = localPtr;
    }
    procPtr->numArgs = argc;
    procPtr->numCompiledLocals = argc;

    /*
     *  If the body definition starts with '@', then treat the value
     *  as a symbolic name for a C procedure.
     */
    if (body == NULL) {
        mcode->flags |= ITCL_IMPLEMENT_NONE;
    }
    else if (*body == '@') {
        Tcl_CmdProc *argCmdProc;
        Tcl_ObjCmdProc *objCmdProc;
        ClientData cdata;

        if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "no registered C procedure with name \"", body+1, "\"",
                (char*)NULL);
            Itcl_DeleteMemberCode((char*)mcode);
            return TCL_ERROR;
        }

        if (objCmdProc != NULL) {
            mcode->flags |= ITCL_IMPLEMENT_OBJCMD;
            mcode->cfunc.objCmd = objCmdProc;
            mcode->clientData = cdata;
        }
        else if (argCmdProc != NULL) {
            mcode->flags |= ITCL_IMPLEMENT_ARGCMD;
            mcode->cfunc.argCmd = argCmdProc;
            mcode->clientData = cdata;
        }
    }

    /*
     *  Otherwise, treat the body as a chunk of Tcl code.
     */
    else {
        mcode->flags |= ITCL_IMPLEMENT_TCL;
    }

    *mcodePtr = mcode;
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DeleteMemberCode()
 *
 *  Destroys all data associated with the given command implementation.
 *  Invoked automatically by Itcl_ReleaseData() when the implementation
 *  is no longer being used.
 * ------------------------------------------------------------------------
 */
void
Itcl_DeleteMemberCode(cdata)
    char* cdata;  /* pointer to member function definition */
{
    ItclMemberCode* mcode = (ItclMemberCode*)cdata;

    if (mcode->arglist) {
        Itcl_DeleteArgList(mcode->arglist);
    }
    if (mcode->procPtr) {
        ckfree((char*) mcode->procPtr->cmdPtr);

        /* don't free compiled locals -- that is handled by arglist above */

        if (mcode->procPtr->bodyPtr) {
            Tcl_DecrRefCount(mcode->procPtr->bodyPtr);
        }
        ckfree((char*)mcode->procPtr);
    }
    ckfree((char*)mcode);
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_GetMemberCode()
 *
 *  Makes sure that the implementation for an [incr Tcl] code body is
 *  ready to run.  Note that a member function can be declared without
 *  being defined.  The class definition may contain a declaration of
 *  the member function, but its body may be defined in a separate file.
 *  If an undefined function is encountered, this routine automatically
 *  attempts to autoload it.  If the body is implemented via Tcl code,
 *  then it is compiled here as well.
 *
 *  Returns TCL_ERROR (along with an error message in the interpreter)
 *  if an error is encountered, or if the implementation is not defined
 *  and cannot be autoloaded.  Returns TCL_OK if implementation is
 *  ready to use.
 * ------------------------------------------------------------------------
 */
int
Itcl_GetMemberCode(interp, member)
    Tcl_Interp* interp;        /* interpreter managing this action */