itcl_obsolete.c

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

                    valv[valc++] = objPtr;
                }
            }
            if (methodBody) {
                objPtr = mcode->procPtr->bodyPtr;
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
            }

            /*
             *  If the result list has a single element, then
             *  return it using Tcl_SetResult() so that it will
             *  look like a string and not a list with one element.
             */
            if (valc == 1) {
                objPtr = valv[0];
            } else {
                objPtr = Tcl_NewListObj(valc, valv);
            }
            Tcl_SetObjResult(interp, objPtr);

            for (i=0; i < valc; i++) {
                Tcl_DecrRefCount(valv[i]);
            }
        }
    }

    /*
     *  Return the list of available methods.
     */
    else {
        listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);

        Itcl_InitHierIter(&hier, contextClass);
        while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
            entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
            while (entry) {
                mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);

                if ((mfunc->member->flags & ITCL_COMMON) == 0) {
                    objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, mfunc->member->name, -1);

                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
                        objPtr);
                }
                entry = Tcl_NextHashEntry(&place);
            }
        }
        Itcl_DeleteHierIter(&hier);

        Tcl_SetObjResult(interp, listPtr);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldBiInfoProcsCmd()
 *
 *  Returns information regarding procs for a class.  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 proc ?procName? ?-args? ?-body?
 *
 *  If the ?procName? is not specified, then a list of all known
 *  procs is returned.  Otherwise, the information (args/body) for
 *  a specific proc is returned.  Returns a status TCL_OK/TCL_ERROR
 *  to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiInfoProcsCmd(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 *procName = NULL;
    int procArgs = 0;
    int procBody = 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:  ?procName? ?-args? ?-body?
     */
    objv++;  /* skip over command name */
    objc--;

    if (objc > 0) {
        procName = Tcl_GetStringFromObj(*objv, (int*)NULL);
        objc--; objv++;
    }
    for ( ; objc > 0; objc--, objv++) {
        token = Tcl_GetStringFromObj(*objv, (int*)NULL);
        if (strcmp(token, "-args") == 0)
            procArgs = ~0;
        else if (strcmp(token, "-body") == 0)
            procBody = ~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 proc.
     */
    if (procName) {
        entry = Tcl_FindHashEntry(&contextClass->resolveCmds, procName);
        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 (!procArgs && !procBody) {
                objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
                procArgs = procBody = ~0;
            }
            if (procArgs) {
                if (mcode->arglist) {
                    objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
                    Tcl_IncrRefCount(objPtr);
                    valv[valc++] = objPtr;
                }
                else {
                    objPtr = Tcl_NewStringObj("", -1);
                    Tcl_IncrRefCount(objPtr);
                    valv[valc++] = objPtr;
                }
            }
            if (procBody) {
                objPtr = mcode->procPtr->bodyPtr;
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
            }

            /*
             *  If the result list has a single element, then
             *  return it using Tcl_SetResult() so that it will
             *  look like a string and not a list with one element.
             */
            if (valc == 1) {
                objPtr = valv[0];
            } else {
                objPtr = Tcl_NewListObj(valc, valv);
            }
            Tcl_SetObjResult(interp, objPtr);

            for (i=0; i < valc; i++) {
                Tcl_DecrRefCount(valv[i]);
            }
        }
    }

    /*
     *  Return the list of available procs.
     */
    else {
        listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);

        Itcl_InitHierIter(&hier, contextClass);
        while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
            entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
            while (entry) {
                mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);

                if ((mfunc->member->flags & ITCL_COMMON) != 0) {
                    objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
                    Tcl_AppendToObj(objPtr, "::", -1);
                    Tcl_AppendToObj(objPtr, mfunc->member->name, -1);

                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
                        objPtr);
                }
                entry = Tcl_NextHashEntry(&place);
            }
        }
        Itcl_DeleteHierIter(&hier);

        Tcl_SetObjResult(interp, listPtr);
    }
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  ItclOldBiInfoPublicsCmd()
 *
 *  Sets the interpreter result to contain information for public
 *  variables in the class.  Handles the following syntax:
 *
 *     info public ?varName? ?-init? ?-value? ?-config?
 *
 *  If the ?varName? is not specified, then a list of all known public
 *  variables is returned.  Otherwise, the information (init/value/config)
 *  for a specific variable is returned.  Returns a status
 *  TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
static int
ItclOldBiInfoPublicsCmd(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 *varName = NULL;
    int varInit = 0;
    int varCheck = 0;
    int varValue = 0;

    char *token, *val;
    ItclClass *contextClass;
    ItclObject *contextObj;

    ItclClass *cdPtr;
    ItclVarLookup *vlookup;
    ItclVarDefn *vdefn;
    ItclMember *member;
    ItclHierIter hier;
    Tcl_HashEntry *entry;
    Tcl_HashSearch place;
    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;
    }

    /*
     *  Process args:  ?varName? ?-init? ?-value? ?-config?
     */
    objv++;  /* skip over command name */
    objc--;

    if (objc > 0) {
        varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
        objc--; objv++;
    }
    for ( ; objc > 0; objc--, objv++) {
        token = Tcl_GetStringFromObj(*objv, (int*)NULL);
        if (strcmp(token, "-init") == 0)
            varInit = ~0;
        else if (strcmp(token, "-value") == 0)
            varValue = ~0;
        else if (strcmp(token, "-config") == 0)
            varCheck = ~0;
        else {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad option \"", token,
                "\": should be -init, -value or -config",
                (char*)NULL);
            return TCL_ERROR;
        }
    }

    /*
     *  Return info for a specific variable.
     */
    if (varName) {
        vlookup = NULL;
        entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
        if (entry) {
            vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
            if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
                vlookup = NULL;
            }
        }

        if (vlookup) {
            int i, valc = 0;
            Tcl_Obj *valv[5];

            member = vlookup->vdefn->member;

            if (!varInit && !varCheck && !varValue) {
                objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
                Tcl_AppendToObj(objPtr, "::", -1);
                Tcl_AppendToObj(objPtr, member->name, -1);
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
                varInit = varCheck = varValue = ~0;
            }
            if (varInit) {
                val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
                objPtr = Tcl_NewStringObj(val, -1);
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
            }
            if (varValue) {
                val = Itcl_GetInstanceVar(interp, member->fullname,
                    contextObj, contextObj->classDefn);

                if (!val) {
                    val = "<undefined>";
                }
                objPtr = Tcl_NewStringObj(val, -1);
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
            }

            if (varCheck) {
                if (member->code && member->code->procPtr->bodyPtr) {
                    objPtr = member->code->procPtr->bodyPtr;
                } else {
                    objPtr = Tcl_NewStringObj("", -1);
                }
                Tcl_IncrRefCount(objPtr);
                valv[valc++] = objPtr;
            }

            /*
             *  If the result list has a single element, then
             *  return it using Tcl_SetResult() so that it will
             *  look like a string and not a list with one element.
             */
            if (valc == 1) {
                objPtr = valv[0];
            } else {
                objPtr = Tcl_NewListObj(valc, valv);
            }
            Tcl_SetObjResult(interp, objPtr);

            for (i=0; i < valc; i++) {
                Tcl_DecrRefCount(valv[i]);
            }
        }
    }

    /*
     *  Return the list of public variables.
     */
    else {
        listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);