itcl_bicmds.c

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

    objc--;

    if (objc > 0) {
        varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
        objc--; objv++;
    }

    /*
     *  Return info for a specific variable.
     */
    if (varName) {
        entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
        if (entry == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "\"", varName, "\" isn't a variable in class \"",
                contextClass->namesp->fullName, "\"",
                (char*)NULL);
            return TCL_ERROR;
        }

        vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
        member = vlookup->vdefn->member;

        /*
         *  By default, return everything.
         */
        if (objc == 0) {
            if (member->protection == ITCL_PUBLIC &&
                ((member->flags & ITCL_COMMON) == 0)) {
                ivlist = DefInfoPubVariable;
                objc = 6;
            } else {
                ivlist = DefInfoVariable;
                objc = 5;
            }
        }

        /*
         *  Otherwise, scan through all remaining flags and
         *  figure out what to return.
         */
        else {
            ivlist = &ivlistStorage[0];
            for (i=0 ; i < objc; i++) {
                result = Tcl_GetIndexFromObj(interp, objv[i],
                    options, "option", 0, (int*)(&ivlist[i]));
                if (result != TCL_OK) {
                    return TCL_ERROR;
                }
            }
        }

        if (objc > 1) {
            resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
        }

        for (i=0 ; i < objc; i++) {
            switch (ivlist[i]) {
                case BIvConfigIdx:
                    if (member->code && member->code->procPtr->bodyPtr) {
                        objPtr = member->code->procPtr->bodyPtr;
                    } else {
                        objPtr = Tcl_NewStringObj("", -1);
                    }
                    break;

                case BIvInitIdx:
                    /*
                     *  If this is the built-in "this" variable, then
                     *  report the object name as its initialization string.
                     */
                    if ((member->flags & ITCL_THIS_VAR) != 0) {
                        if (contextObj && contextObj->accessCmd) {
                            objPtr = Tcl_NewStringObj((char*)NULL, 0);
                            Tcl_GetCommandFullName(
                                contextObj->classDefn->interp,
                                contextObj->accessCmd, objPtr);
                        } else {
                            objPtr = Tcl_NewStringObj("<objectName>", -1);
                        }
                    }
                    else if (vlookup->vdefn->init) {
                        objPtr = Tcl_NewStringObj(vlookup->vdefn->init, -1);
                    }
                    else {
                        objPtr = Tcl_NewStringObj("<undefined>", -1);
                    }
                    break;

                case BIvNameIdx:
                    objPtr = Tcl_NewStringObj(member->fullname, -1);
                    break;

                case BIvProtectIdx:
                    val = Itcl_ProtectionStr(member->protection);
                    objPtr = Tcl_NewStringObj(val, -1);
                    break;

                case BIvTypeIdx:
                    val = ((member->flags & ITCL_COMMON) != 0)
                        ? "common" : "variable";
                    objPtr = Tcl_NewStringObj(val, -1);
                    break;

                case BIvValueIdx:
                    if ((member->flags & ITCL_COMMON) != 0) {
                        val = Itcl_GetCommonVar(interp, member->fullname,
                            member->classDefn);
                    }
                    else if (contextObj == NULL) {
                        Tcl_ResetResult(interp);
                        Tcl_AppendResult(interp,
                            "cannot access object-specific info ",
                            "without an object context",
                            (char*)NULL);
                        return TCL_ERROR;
                    }
                    else {
                        val = Itcl_GetInstanceVar(interp, member->fullname,
                            contextObj, member->classDefn);
                    }

                    if (val == NULL) {
                        val = "<undefined>";
                    }
                    objPtr = Tcl_NewStringObj(val, -1);
                    break;
            }

            if (objc == 1) {
                resultPtr = objPtr;
            } else {
                Tcl_ListObjAppendElement((Tcl_Interp*)NULL, resultPtr,
                    objPtr);
            }
        }
        Tcl_SetObjResult(interp, resultPtr);
    }

    /*
     *  Return the list of available variables.  Report the built-in
     *  "this" variable only once, for the most-specific class.
     */
    else {
        resultPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);

        Itcl_InitHierIter(&hier, contextClass);
        while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
            entry = Tcl_FirstHashEntry(&cdefn->variables, &place);
            while (entry) {
                vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
                if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) {
                    if (cdefn == contextClass) {
                        objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
                        Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
                            resultPtr, objPtr);
                    }
                }
                else {
                    objPtr = Tcl_NewStringObj(vdefn->member->fullname, -1);
                    Tcl_ListObjAppendElement((Tcl_Interp*)NULL,
                        resultPtr, objPtr);
                }
                entry = Tcl_NextHashEntry(&place);
            }
        }
        Itcl_DeleteHierIter(&hier);

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


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiInfoBodyCmd()
 *
 *  Handles the usual "info body" request, returning the body for a
 *  specific proc.  Included here for backward compatibility, since
 *  otherwise Tcl would complain that class procs are not real "procs".
 *  Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiInfoBodyCmd(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 *name;
    ItclClass *contextClass;
    ItclObject *contextObj;
    ItclMemberFunc *mfunc;
    ItclMemberCode *mcode;
    Tcl_HashEntry *entry;
    Tcl_Obj *objPtr;

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

    /*
     *  If this command is not invoked within a class namespace,
     *  then treat the procedure name as a normal Tcl procedure.
     */
    if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
        Proc *procPtr;

        name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
        procPtr = TclFindProc((Interp*)interp, name);
        if (procPtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "\"", name, "\" isn't a procedure",
                (char*)NULL);
            return TCL_ERROR;
        }
        Tcl_SetObjResult(interp, procPtr->bodyPtr);
    }

    /*
     *  Otherwise, treat the name as a class method/proc.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\nget info like this instead: ",
            "\n  namespace eval className { info ", name, "... }",
            (char*)NULL);
        return TCL_ERROR;
    }

    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
    entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
    if (entry == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" isn't a procedure",
            (char*)NULL);
        return TCL_ERROR;
    }

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

    /*
     *  Return a string describing the implementation.
     */
    if (mcode && mcode->procPtr->bodyPtr) {
        objPtr = mcode->procPtr->bodyPtr;
    } else {
        objPtr = Tcl_NewStringObj("<undefined>", -1);
    }
    Tcl_SetObjResult(interp, objPtr);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_BiInfoArgsCmd()
 *
 *  Handles the usual "info args" request, returning the argument list
 *  for a specific proc.  Included here for backward compatibility, since
 *  otherwise Tcl would complain that class procs are not real "procs".
 *  Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_BiInfoArgsCmd(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 *name;
    ItclClass *contextClass;
    ItclObject *contextObj;
    ItclMemberFunc *mfunc;
    ItclMemberCode *mcode;
    Tcl_HashEntry *entry;
    Tcl_Obj *objPtr;

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

    name = Tcl_GetStringFromObj(objv[1], (int*)NULL);

    /*
     *  If this command is not invoked within a class namespace,
     *  then treat the procedure name as a normal Tcl procedure.
     */
    if (!Itcl_IsClassNamespace(Tcl_GetCurrentNamespace(interp))) {
        Proc *procPtr;
        CompiledLocal *localPtr;

        procPtr = TclFindProc((Interp*)interp, name);
        if (procPtr == NULL) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "\"", name, "\" isn't a procedure",
                (char*)NULL);
            return TCL_ERROR;
        }

        objPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL);
        for (localPtr = procPtr->firstLocalPtr;
             localPtr != NULL;
             localPtr = localPtr->nextPtr) {
            if (TclIsVarArgument(localPtr)) {
                Tcl_ListObjAppendElement(interp, objPtr,
                    Tcl_NewStringObj(localPtr->name, -1));
            }
        }

        Tcl_SetObjResult(interp, objPtr);
    }

    /*
     *  Otherwise, treat the name as a class method/proc.
     */
    if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
        name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\nget info like this instead: ",
            "\n  namespace eval className { info ", name, "... }",
            (char*)NULL);
        return TCL_ERROR;
    }

    entry = Tcl_FindHashEntry(&contextClass->resolveCmds, name);
    if (entry == NULL) {
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
            "\"", name, "\" isn't a procedure",
            (char*)NULL);
        return TCL_ERROR;
    }

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

    /*
     *  Return a string describing the argument list.
     */
    if (mcode && mcode->arglist != NULL) {
        objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
    }
    else if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0) {
        objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist);
    }
    else {
        objPtr = Tcl_NewStringObj("<undefined>", -1);
    }
    Tcl_SetObjResult(interp, objPtr);
    return TCL_OK;
}


/*
 * ------------------------------------------------------------------------
 *  Itcl_DefaultInfoCmd()
 *
 *  Handles any unknown options for the "itcl::builtin::info" command
 *  by passing requests on to the usual "::info" command.  If the
 *  option is recognized, then it is handled.  Otherwise, if it is
 *  still unknown, then an error message is returned with the list
 *  of possible options.
 *
 *  Returns TCL_OK/TCL_ERROR to indicate success/failure.
 * ------------------------------------------------------------------------
 */
/* ARGSUSED */
int
Itcl_DefaultInfoCmd(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;
    Tcl_Command cmd;
    Command *cmdPtr;
    Tcl_Obj *resultPtr;

    /*
     *  Look for the usual "::info" command, and use it to
     *  evaluate the unknown option.
     */
    cmd = Tcl_FindCommand(interp, "::info", (Tcl_Namespace*)NULL, 0);
    if (cmd == NULL) {
        name = Tcl_GetStringFromObj(objv[0], (int*)NULL);
        Tcl_ResetResult(interp);

        resultPtr = Tcl_GetObjResult(interp);
        Tcl_AppendStringsToObj(resultPtr,
            "bad option \"", name, "\" should be one of...\n",
            (char*)NULL);
        Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);

        return TCL_ERROR;
    }

    cmdPtr = (Command*)cmd;
    result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);

    /*
     *  If the option was not recognized by the usual "info" command,
     *  then we got a "bad option" error message.  Add the options
     *  for the current ensemble to the error message.
     */
    if (result != TCL_OK && strncmp(interp->result,"bad option",10) == 0) {
        resultPtr = Tcl_GetObjResult(interp);
        Tcl_AppendToObj(resultPtr, "\nor", -1);
        Itcl_GetEnsembleUsageForObj(interp, objv[0], resultPtr);
    }
    return result;
}