tclcmdil.c

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

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 2, objv, NULL);
        return TCL_ERROR;
    }
    
#ifdef TCL_SHLIB_EXT
    Tcl_SetStringObj(Tcl_GetObjResult(interp), TCL_SHLIB_EXT, -1);
#endif
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoTclVersionCmd --
 *
 *      Called to implement the "info tclversion" command that returns the
 *      version number for this Tcl library. Handles the following syntax:
 *
 *          info tclversion
 *
 * 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
InfoTclVersionCmd(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 *version;

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

    version = Tcl_GetVar(interp, "tcl_version",
        (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
    if (version != NULL) {
        Tcl_SetStringObj(Tcl_GetObjResult(interp), version, -1);
        return TCL_OK;
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * InfoVarsCmd --
 *
 *	Called to implement the "info vars" command that returns the
 *	list of variables in the interpreter that match an optional pattern.
 *	The pattern, if any, consists of an optional sequence of namespace
 *	names separated by "::" qualifiers, which is followed by a
 *	glob-style pattern that restricts which variables are returned.
 *	Handles the following syntax:
 *
 *          info vars ?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
InfoVarsCmd(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;
    char *varName, *pattern;
    CONST char *simplePattern;
    register Tcl_HashEntry *entryPtr;
    Tcl_HashSearch search;
    Var *varPtr;
    Namespace *nsPtr;
    Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
    Namespace *currNsPtr   = (Namespace *) Tcl_GetCurrentNamespace(interp);
    Tcl_Obj *listPtr, *elemObjPtr;
    int specificNsInPattern = 0;  /* Init. to avoid compiler warning. */

    /*
     * Get the pattern and find the "effective namespace" in which to
     * list variables. We only use this effective namespace if there's
     * no active Tcl procedure frame.
     */

    if (objc == 2) {
        simplePattern = NULL;
	nsPtr = currNsPtr;
	specificNsInPattern = 0;
    } else if (objc == 3) {
	/*
	 * From the pattern, get the effective namespace and the simple
	 * pattern (no namespace qualifiers or ::'s) at the end. If an
	 * error was found while parsing the pattern, return it. Otherwise,
	 * if the namespace wasn't found, just leave nsPtr NULL: we will
	 * return an empty list since no variables there can be found.
	 */

	Namespace *dummy1NsPtr, *dummy2NsPtr;

        pattern = Tcl_GetString(objv[2]);
	TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
		/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
		&simplePattern);

	if (nsPtr != NULL) {	/* we successfully found the pattern's ns */
	    specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
	}
    } else {
        Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
        return TCL_ERROR;
    }

    /*
     * If the namespace specified in the pattern wasn't found, just return.
     */

    if (nsPtr == NULL) {
	return TCL_OK;
    }
    
    listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
    
    if ((iPtr->varFramePtr == NULL)
	    || !iPtr->varFramePtr->isProcCallFrame
	    || specificNsInPattern) {
	/*
	 * There is no frame pointer, the frame pointer was pushed only
	 * to activate a namespace, or we are in a procedure call frame
	 * but a specific namespace was specified. Create a list containing
	 * only the variables in the effective namespace's variable table.
	 */
	
	entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
	while (entryPtr != NULL) {
	    varPtr = (Var *) Tcl_GetHashValue(entryPtr);
	    if (!TclIsVarUndefined(varPtr)
		    || (varPtr->flags & VAR_NAMESPACE_VAR)) {
		varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
		if ((simplePattern == NULL)
	                || Tcl_StringMatch(varName, simplePattern)) {
		    if (specificNsInPattern) {
			elemObjPtr = Tcl_NewObj();
			Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
			        elemObjPtr);
		    } else {
			elemObjPtr = Tcl_NewStringObj(varName, -1);
		    }
		    Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
		}
	    }
	    entryPtr = Tcl_NextHashEntry(&search);
	}

	/*
	 * If the effective namespace isn't the global :: namespace, and a
	 * specific namespace wasn't requested in the pattern (i.e., the
	 * pattern only specifies variable names), then add in all global ::
	 * variables that match the simple pattern. Of course, add in only
	 * those variables that aren't hidden by a variable in the effective
	 * namespace.
	 */

	if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
	    entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
	    while (entryPtr != NULL) {
		varPtr = (Var *) Tcl_GetHashValue(entryPtr);
		if (!TclIsVarUndefined(varPtr)
		        || (varPtr->flags & VAR_NAMESPACE_VAR)) {
		    varName = Tcl_GetHashKey(&globalNsPtr->varTable,
			    entryPtr);
		    if ((simplePattern == NULL)
	                    || Tcl_StringMatch(varName, simplePattern)) {
			if (Tcl_FindHashEntry(&nsPtr->varTable, varName) == NULL) {
			    Tcl_ListObjAppendElement(interp, listPtr,
			            Tcl_NewStringObj(varName, -1));
			}
		    }
		}
		entryPtr = Tcl_NextHashEntry(&search);
	    }
	}
    } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
	AppendLocals(interp, listPtr, simplePattern, 1);
    }
    
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinObjCmd --
 *
 *	This procedure is invoked to process the "join" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_JoinObjCmd(dummy, interp, objc, objv)
    ClientData dummy;		/* Not used. */
    Tcl_Interp *interp;		/* Current interpreter. */
    int objc;			/* Number of arguments. */
    Tcl_Obj *CONST objv[];	/* The argument objects. */
{
    char *joinString, *bytes;
    int joinLength, listLen, length, i, result;
    Tcl_Obj **elemPtrs;
    Tcl_Obj *resObjPtr;

    if (objc == 2) {
	joinString = " ";
	joinLength = 1;
    } else if (objc == 3) {
	joinString = Tcl_GetStringFromObj(objv[2], &joinLength);
    } else {
	Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
	return TCL_ERROR;
    }

    /*
     * Make sure the list argument is a list object and get its length and
     * a pointer to its array of element pointers.
     */

    result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs);
    if (result != TCL_OK) {
	return result;
    }

    /*
     * Now concatenate strings to form the "joined" result. We append
     * directly into the interpreter's result object.
     */

    resObjPtr = Tcl_GetObjResult(interp);

    for (i = 0;  i < listLen;  i++) {
	bytes = Tcl_GetStringFromObj(elemPtrs[i], &length);
	if (i > 0) {
	    Tcl_AppendToObj(resObjPtr, joinString, joinLength);
	}
	Tcl_AppendToObj(resObjPtr, bytes, length);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LindexObjCmd --
 *
 *	This object-based procedure is invoked to process the "lindex" Tcl
 *	command. See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl object result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

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

    Tcl_Obj *elemPtr;		/* Pointer to the element being extracted */

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

    /*
     * If objc == 3, then objv[ 2 ] may be either a single index or
     * a list of indices: go to TclLindexList to determine which.
     * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
     * single indices and processed as such in TclLindexFlat.
     */

    if ( objc == 3 ) {

	elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );

    } else {

	elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );

    }
	
    /*
     * Set the interpreter's object result to the last element extracted
     */

    if ( elemPtr == NULL ) {
	return TCL_ERROR;
    } else {
	Tcl_SetObjResult(interp, elemPtr);
	Tcl_DecrRefCount( elemPtr );
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclLindexList --
 *
 *	This procedure handles the 'lindex' command when objc==3.
 *
 * Results:
 *	Returns a pointer to the object extracted, or NULL if an
 *	error occurred.
 *
 * Side effects:
 *	None.
 *
 * If objv[1] can be parsed as a list, TclLindexList handles extraction
 * of the desired element locally.  Otherwise, it invokes
 * TclLindexFlat to treat objv[1] as a scalar.
 *
 * The reference count of the returned object includes one reference
 * corresponding to the pointer returned.  Thus, the calling code will
 * usually do something like:
 *	Tcl_SetObjResult( interp, result );
 *	Tcl_DecrRefCount( result );
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclLindexList( interp, listPtr, argPtr )
    Tcl_Interp* interp;		/* Tcl interpreter */
    Tcl_Obj* listPtr;		/* List being unpacked */
    Tcl_Obj* argPtr;		/* Index or index list */
{

    Tcl_Obj **elemPtrs;		/* Elements of the list being manipulated. */
    int listLen;		/* Length of the list being manipulated. */
    int index;			/* Index into the list */
    int result;			/* Result returned from a Tcl library call */
    int i;			/* Current index number */
    Tcl_Obj** indices;		/* Array of list indices */
    int indexCount;		/* Size of the array of list indices */
    Tcl_Obj* oldListPtr;	/* Temp location to preserve the list
				 * pointer when replacing it with a sublist */

    /*
     * Determine whether argPtr designates a list or a single index.
     * We have to be careful about the order of the checks to avoid
     * repeated shimmering; see TIP#22 and TIP#33 for the details.
     */

    if ( argPtr->typePtr != &tclListType 
	 && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {

	/*
	 * argPtr designates a single index.
	 */

	return TclLindexFlat( interp, listPtr, 1, &argPtr );

    } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
		!= TCL_OK ) {

	/*
	 * argPtr designates something that is neither an index nor a
	 * well-formed list.  Report the error via TclLindexFlat.
	 */
	
	return TclLindexFlat( interp, listPtr, 1, &argPtr );
    }

    /*
     * Record the reference to the list that we are maintaining in
     * the activation record.
     */

    Tcl_IncrRefCount( listPtr );

    /*
     * argPtr designates a list, and the 'else if' above has parsed it
     * into indexCount and indices.
     */

    for ( i = 0; i < indexCount; ++i ) {

	/*
	 * Convert the current listPtr to a list if necessary.
	 */
	    
	result = Tcl_ListObjGetElements( interp, listPtr,
					 &listLen, &elemPtrs);
	if (result != TCL_OK) {
	    Tcl_DecrRefCount( listPtr );
	    return NULL;
	}