itcl_obsolete.c

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

    nsPtr = (Namespace*)cdefnPtr->namesp;
    entry = Tcl_CreateHashEntry(&nsPtr->varTable,
        vdefn->member->name, &newEntry);

    varPtr = _TclNewVar();
    varPtr->hPtr = entry;
    varPtr->nsPtr = nsPtr;
    varPtr->refCount++;   /* protect from being deleted */

    Tcl_SetHashValue(entry, varPtr);

    /*
     *  TRICKY NOTE:  Make sure to rebuild the virtual tables for this
     *    class so that this variable is ready to access.  The variable
     *    resolver for the parser namespace needs this info to find the
     *    variable if the developer tries to set it within the class
     *    definition.
     *
     *  If an initialization value was specified, then initialize
     *  the variable now.
     */
    Itcl_BuildVirtualTables(cdefnPtr);

    if (init) {
        init = Tcl_SetVar(interp, vdefn->member->name, init,
            TCL_NAMESPACE_ONLY);

        if (!init) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "cannot initialize common variable \"",
                vdefn->member->name, "\"",
                (char*)NULL);
            return TCL_ERROR;
        }
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldDeleteCmd()
 *
 *  Invokes the destructors, and deletes the object that invoked this
 *  operation.  If an error is encountered during destruction, the
 *  delete operation is aborted.  Handles the following syntax:
 *
 *     <objName> delete
 *
 *  When an object is successfully deleted, it is removed from the
 *  list of known objects, and its access command is deleted.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiDeleteCmd(dummy, interp, objc, objv)
    ClientData dummy;     /* not used */
    Tcl_Interp *interp;   /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    ItclClass *contextClass;
    ItclObject *contextObj;

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

    /*
     *  If there is an object context, then destruct the object
     *  and delete it.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    if (!contextObj) {
        Tcl_SetResult(interp, "improper usage: should be \"object delete\"",
            TCL_STATIC);
        return TCL_ERROR;
    }

    if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    Tcl_ResetResult(interp);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldVirtualCmd()
 *
 *  Executes the remainder of its command line arguments in the
 *  most-specific class scope for the current object.  If there is
 *  no object context, this fails.
 *
 *  NOTE:  All methods are now implicitly virtual, and there are
 *    much better ways to manipulate scope.  This command is only
 *    provided for backward-compatibility, and should be avoided.
 *
 *  Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiVirtualCmd(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;
    ItclClass *contextClass;
    ItclObject *contextObj;
    ItclContext context;

    if (objc == 1) {
        Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\n  This command will be removed soon.",
            "\n  Commands are now virtual by default.",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  If there is no object context, then return an error.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }
    if (!contextObj) {
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "cannot use \"virtual\" without an object context\n",
            "  This command will be removed soon.\n",
            "  Commands are now virtual by default.",
            (char*)NULL);
        return TCL_ERROR;
    }

    /*
     *  Install the most-specific namespace for this object, with
     *  the object context as clientData.  Invoke the rest of the
     *  args as a command in that namespace.
     */
    if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
        contextObj, &context) != TCL_OK) {

        return TCL_ERROR;
    }

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

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldPreviousCmd()
 *
 *  Executes the remainder of its command line arguments in the
 *  previous class scope (i.e., the next scope up in the heritage
 *  list).
 *
 *  NOTE:  There are much better ways to manipulate scope.  This
 *    command is only provided for backward-compatibility, and should
 *    be avoided.
 *
 *  Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiPreviousCmd(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;
    char *name;
    ItclClass *contextClass, *base;
    ItclObject *contextObj;
    ItclMember *member;
    ItclMemberFunc *mfunc;
    Itcl_ListElem *elem;
    Tcl_HashEntry *entry;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
        return TCL_ERROR;
    }

    /*
     *  If the current context is not a class namespace,
     *  return an error.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  Get the heritage information for this class and move one
     *  level up in the hierarchy.  If there is no base class,
     *  return an error.
     */
    elem = Itcl_FirstListElem(&contextClass->bases);
    if (!elem) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "no previous class in inheritance hierarchy for \"",
            contextClass->name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }
    base = (ItclClass*)Itcl_GetListValue(elem);

    /*
     *  Look in the command resolution table for the base class
     *  to find the desired method.
     */
    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    entry = Tcl_FindHashEntry(&base->resolveCmds, name);
    if (!entry) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "invalid command name \"", base->name, "::", name, "\"",
            (char*)NULL);
        return TCL_ERROR;
    }

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

    /*
     *  Make sure that this method is accessible.
     */
    if (mfunc->member->protection != ITCL_PUBLIC) {
        Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
            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;
        }
    }

    /*
     *  Invoke the desired method by calling Itcl_EvalMemberCode.
     *  directly.  This bypasses the virtual behavior built into
     *  the usual Itcl_ExecMethod handler.
     */
    result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
        objc-1, objv+1);

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

    return result;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldBiInfoMethodsCmd()
 *
 *  Returns information regarding methods for an object.  This command
 *  can be invoked with or without an object context:
 *
 *    <objName> info...   <= returns info for most-specific class
 *    info...             <= returns info for active namespace
 *
 *  Handles the following syntax:
 *
 *    info method ?methodName? ?-args? ?-body?
 *
 *  If the ?methodName? is not specified, then a list of all known
 *  methods is returned.  Otherwise, the information (args/body) for
 *  a specific method is returned.  Returns a status TCL_OK/TCL_ERROR
 *  to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiInfoMethodsCmd(dummy, interp, objc, objv)
    ClientData dummy;        /* not used */
    Tcl_Interp *interp;      /* current interpreter */
    int objc;                /* number of arguments */
    Tcl_Obj *CONST objv[];   /* argument objects */
{
    char *methodName = NULL;
    int methodArgs = 0;
    int methodBody = 0;

    char *token;
    ItclClass *contextClass, *cdefn;
    ItclObject *contextObj;
    ItclHierIter hier;
    Tcl_HashSearch place;
    Tcl_HashEntry *entry;
    ItclMemberFunc *mfunc;
    ItclMemberCode *mcode;
    Tcl_Obj *objPtr, *listPtr;

    /*
     *  If this command is not invoked within a class namespace,
     *  signal an error.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        return TCL_ERROR;
    }

    /*
     *  If there is an object context, then use the most-specific
     *  class for the object.  Otherwise, use the current class
     *  namespace.
     */
    if (contextObj) {
        contextClass = contextObj->classDefn;
    }

    /*
     *  Process args:  ?methodName? ?-args? ?-body?
     */
    objv++;  /* skip over command name */
    objc--;

    if (objc > 0) {
        methodName = Tcl_GetStringFromObj(*objv, (int*)NULL);
        objc--; objv++;
    }
    for ( ; objc > 0; objc--, objv++) {
        token = Tcl_GetStringFromObj(*objv, (int*)NULL);
        if (strcmp(token, "-args") == 0)
            methodArgs = ~0;
        else if (strcmp(token, "-body") == 0)
            methodBody = ~0;
        else {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad option \"", token, "\": should be -args or -body",
                (char*)NULL);
            return TCL_ERROR;
        }
    }

    /*
     *  Return info for a specific method.
     */
    if (methodName) {
        entry = Tcl_FindHashEntry(&contextClass->resolveCmds, methodName);
        if (entry) {
            int i, valc = 0;
            Tcl_Obj *valv[5];

            mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
            if ((mfunc->member->flags & ITCL_COMMON) != 0) {
                return TCL_OK;
            }

            /*
             *  If the implementation has not yet been defined,
             *  autoload it now.
             */
            if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
                return TCL_ERROR;
            }
            mcode = mfunc->member->code;

            if (!methodArgs && !methodBody) {
                objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
                Tcl_AppendToObj(objPtr, "::", -1);
                Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
                methodArgs = methodBody = ~0;
            }
            if (methodArgs) {
                if (mcode->arglist) {
                    objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
                    Tcl_IncrRefCount(objPtr);
                    valv[valc++] = objPtr;
                }
                else {
                    objPtr = Tcl_NewStringObj("", -1);
                    Tcl_IncrRefCount(objPtr);