tclcmdil.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,174 行 · 第 1/5 页

    if (objc != 5) {
        Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
        return TCL_ERROR;
    }

    procName = Tcl_GetString(objv[2]);
    argName = Tcl_GetString(objv[3]);

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

    for (localPtr = procPtr->firstLocalPtr;  localPtr != NULL;
            localPtr = localPtr->nextPtr) {
        if (TclIsVarArgument(localPtr)
		&& (strcmp(argName, localPtr->name) == 0)) {
            if (localPtr->defValuePtr != NULL) {
		valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
			localPtr->defValuePtr, 0);
                if (valueObjPtr == NULL) {
                    defStoreError:
		    varName = Tcl_GetString(objv[4]);
		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	                    "couldn't store default value in variable \"",
			    varName, "\"", (char *) NULL);
                    return TCL_ERROR;
                }
		Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
            } else {
                Tcl_Obj *nullObjPtr = Tcl_NewObj();
                valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
			nullObjPtr, 0);
                if (valueObjPtr == NULL) {
                    Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
                    goto defStoreError;
                }
		Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
            }
            return TCL_OK;
        }
    }

    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
	    "procedure \"", procName, "\" doesn't have an argument \"",
	    argName, "\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoExistsCmd --
 *
 *      Called to implement the "info exists" command that determines
 *      whether a variable exists. Handles the following syntax:
 *
 *          info exists varName
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoExistsCmd(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;
    Var *varPtr;

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

    varName = Tcl_GetString(objv[2]);
    varPtr = TclVarTraceExists(interp, varName);
    if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
    } else {
        Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoFunctionsCmd --
 *
 *      Called to implement the "info functions" command that returns the
 *      list of math functions matching an optional pattern. Handles the
 *      following syntax:
 *
 *          info functions ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoFunctionsCmd(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 *pattern;
    Tcl_Obj *listPtr;

    if (objc == 2) {
        pattern = NULL;
    } else if (objc == 3) {
        pattern = Tcl_GetString(objv[2]);
    } else {
        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
        return TCL_ERROR;
    }

    listPtr = Tcl_ListMathFuncs(interp, pattern);
    if (listPtr == NULL) {
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoGlobalsCmd --
 *
 *      Called to implement the "info globals" command that returns the list
 *      of global variables matching an optional pattern. Handles the
 *      following syntax:
 *
 *          info globals ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoGlobalsCmd(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, *pattern;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Var *varPtr;
    Tcl_Obj *listPtr;

    if (objc == 2) {
        pattern = NULL;
    } else if (objc == 3) {
        pattern = Tcl_GetString(objv[2]);
    } else {
        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
        return TCL_ERROR;
    }

    /*
     * Scan through the global :: namespace's variable table and create a
     * list of all global variables that match the pattern.
     */
    
    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
            entryPtr != NULL;
            entryPtr = Tcl_NextHashEntry(&search)) {
        varPtr = (Var *) Tcl_GetHashValue(entryPtr);
        if (TclIsVarUndefined(varPtr)) {
            continue;
        }
        varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
        if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
            Tcl_ListObjAppendElement(interp, listPtr,
		    Tcl_NewStringObj(varName, -1));
        }
    }
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoHostnameCmd --
 *
 *      Called to implement the "info hostname" command that returns the
 *      host name. Handles the following syntax:
 *
 *          info hostname
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoHostnameCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    CONST char *name;
    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
        return TCL_ERROR;
    }

    name = Tcl_GetHostName();
    if (name) {
	Tcl_SetStringObj(Tcl_GetObjResult(interp), name, -1);
	return TCL_OK;
    } else {
	Tcl_SetStringObj(Tcl_GetObjResult(interp),
		"unable to determine name of host", -1);
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLevelCmd --
 *
 *      Called to implement the "info level" command that returns
 *      information about the call stack. Handles the following syntax:
 *
 *          info level ?number?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLevelCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    int level;
    CallFrame *framePtr;
    Tcl_Obj *listPtr;

    if (objc == 2) {		/* just "info level" */
        if (iPtr->varFramePtr == NULL) {
            Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
        } else {
            Tcl_SetIntObj(Tcl_GetObjResult(interp), iPtr->varFramePtr->level);
        }
        return TCL_OK;
    } else if (objc == 3) {
        if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
            return TCL_ERROR;
        }
        if (level <= 0) {
            if (iPtr->varFramePtr == NULL) {
                levelError:
		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			"bad level \"",
			Tcl_GetString(objv[2]),
			"\"", (char *) NULL);
                return TCL_ERROR;
            }
            level += iPtr->varFramePtr->level;
        }
        for (framePtr = iPtr->varFramePtr;  framePtr != NULL;
                framePtr = framePtr->callerVarPtr) {
            if (framePtr->level == level) {
                break;
            }
        }
        if (framePtr == NULL) {
            goto levelError;
        }

        listPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
        Tcl_SetObjResult(interp, listPtr);
        return TCL_OK;
    }

    Tcl_WrongNumArgs(interp, 2, objv, "?number?");
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLibraryCmd --
 *
 *      Called to implement the "info library" command that returns the
 *      library directory for the Tcl installation. Handles the following
 *      syntax:
 *
 *          info library
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLibraryCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* Argument objects. */
{
    CONST char *libDirName;

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

    libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
    if (libDirName != NULL) {
        Tcl_SetStringObj(Tcl_GetObjResult(interp), libDirName, -1);
        return TCL_OK;
    }
    Tcl_SetStringObj(Tcl_GetObjResult(interp), 
            "no library has been specified for Tcl", -1);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLoadedCmd --
 *
 *      Called to implement the "info loaded" command that returns the
 *      packages that have been loaded into an interpreter. Handles the
 *      following syntax:
 *
 *          info loaded ?interp?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is
 *	an error, the result is an error message.
 *
 *----------------------------------------------------------------------
 */

static int
InfoLoadedCmd(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 *interpName;
    int result;

    if ((objc != 2) && (objc != 3)) {
        Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
        return TCL_ERROR;
    }

    if (objc == 2) {		/* get loaded pkgs in all interpreters */
	interpName = NULL;
    } else {			/* get pkgs just in specified interp */
	interpName = Tcl_GetString(objv[2]);
    }
    result = TclGetLoadedPackages(interp, interpName);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoLocalsCmd --
 *
 *      Called to implement the "info locals" command to return a list of
 *      local variables that match an optional pattern. Handles the
 *      following syntax:
 *
 *          info locals ?pattern?
 *
 * Results:
 *      Returns TCL_OK if successful and TCL_ERROR if there is an error.
 *
 * Side effects:
 *      Returns a result in the interpreter's result object. If there is