#ifndef EXCLUDE_TCL/*  * tclCmdIL.c -- * *	This file contains the top-level command routines for most of *	the Tcl built-in commands whose names begin with the letters *	I through L.  It contains only commands in the generic core *	(i.e. those that don't depend much upon UNIX facilities). * * Copyright 1987-1991 Regents of the University of California * Permission to use, copy, modify, and distribute this * software and its documentation for any purpose and without * fee is hereby granted, provided that the above copyright * notice appear in all copies.  The University of California * makes no representations about the suitability of this * software for any purpose.  It is provided "as is" without * express or implied warranty. */#include "tclInt.h"/* * Forward declarations for procedures defined in this file: */static int		SortCompareProc _ANSI_ARGS_((CONST VOID *first,			    CONST VOID *second));/* *---------------------------------------------------------------------- * * Tcl_IfCmd -- * *	This procedure is invoked to process the "if" Tcl command. *	See the user documentation for details on what it does. * * Results: *	A standard Tcl result. * * Side effects: *	See the user documentation. * *---------------------------------------------------------------------- */	/* ARGSUSED */intTcl_IfCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    int i, result, value;    i = 1;    while (1) {	/*	 * At this point in the loop, argv and argc refer to an expression	 * to test, either for the main expression or an expression	 * following an "elseif".  The arguments after the expression must	 * be "then" (optional) and a script to execute if the expression is	 * true.	 */	if (i >= argc) {	    Tcl_AppendResult(interp, "wrong # args: no expression after \"",		    argv[i-1], "\" argument", (char *) NULL);	    return TCL_ERROR;	}	result = Tcl_ExprBoolean(interp, argv[i], &value);	if (result != TCL_OK) {	    return result;	}	i++;	if ((i < argc) && (strcmp(argv[i], "then") == 0)) {	    i++;	}	if (i >= argc) {	    Tcl_AppendResult(interp, "wrong # args: no script following \"",		    argv[i-1], "\" argument", (char *) NULL);	    return TCL_ERROR;	}	if (value) {	    return Tcl_Eval(interp, argv[i], 0, (char **) NULL);	}	/*	 * The expression evaluated to false.  Skip the command, then	 * see if there is an "else" or "elseif" clause.	 */	i++;	if (i >= argc) {	    return TCL_OK;	}	if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {	    i++;	    continue;	}	break;    }    /*     * Couldn't find a "then" or "elseif" clause to execute.  Check now     * for an "else" clause.  We know that there's at least one more     * argument when we get here.     */    if (strcmp(argv[i], "else") == 0) {	i++;	if (i >= argc) {	    Tcl_AppendResult(interp,		    "wrong # args: no script following \"else\" argument",		    (char *) NULL);	    return TCL_ERROR;	}    }    return Tcl_Eval(interp, argv[i], 0, (char **) NULL);}/* *---------------------------------------------------------------------- * * Tcl_IncrCmd -- * *	This procedure is invoked to process the "incr" Tcl command. *	See the user documentation for details on what it does. * * Results: *	A standard Tcl result. * * Side effects: *	See the user documentation. * *---------------------------------------------------------------------- */    /* ARGSUSED */intTcl_IncrCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    long value;    char *oldString, *result;    char newString[30];    if ((argc != 2) && (argc != 3)) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" varName ?increment?\"", (char *) NULL);	return TCL_ERROR;    }    oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);    if (oldString == NULL) {	return TCL_ERROR;    }    if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {	Tcl_AddErrorInfo(interp,		"\n    (reading value of variable to increment)");	return TCL_ERROR;    }    if (argc == 2) {	value += 1;    } else {	long increment;	if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {	    Tcl_AddErrorInfo(interp,		    "\n    (reading increment)");	    return TCL_ERROR;	}	value += increment;    }    sprintf(newString, "%ld", value);    result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);    if (result == NULL) {	return TCL_ERROR;    }    interp->result = result;    return TCL_OK; }/* *---------------------------------------------------------------------- * * Tcl_InfoCmd -- * *	This procedure is invoked to process the "info" Tcl command. *	See the user documentation for details on what it does. * * Results: *	A standard Tcl result. * * Side effects: *	See the user documentation. * *---------------------------------------------------------------------- */	/* ARGSUSED */intTcl_InfoCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */    int argc;				/* Number of arguments. */    char **argv;			/* Argument strings. */{    register Interp *iPtr = (Interp *) interp;    int length;    char c;    Arg *argPtr;    Proc *procPtr;    Var *varPtr;    Command *cmdPtr;    Tcl_HashEntry *hPtr;    Tcl_HashSearch search;    if (argc < 2) {	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" option ?arg arg ...?\"", (char *) NULL);	return TCL_ERROR;    }    c = argv[1][0];    length = strlen(argv[1]);    if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {	if (argc != 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"",		    argv[0], " args procname\"", (char *) NULL);	    return TCL_ERROR;	}	procPtr = TclFindProc(iPtr, argv[2]);	if (procPtr == NULL) {	    infoNoSuchProc:	    Tcl_AppendResult(interp, "\"", argv[2],		    "\" isn't a procedure", (char *) NULL);	    return TCL_ERROR;	}	for (argPtr = procPtr->argPtr; argPtr != NULL;		argPtr = argPtr->nextPtr) {	    Tcl_AppendElement(interp, argPtr->name, 0);	}	return TCL_OK;    } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {	if (argc != 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " body procname\"", (char *) NULL);	    return TCL_ERROR;	}	procPtr = TclFindProc(iPtr, argv[2]);	if (procPtr == NULL) {	    goto infoNoSuchProc;	}	iPtr->result = procPtr->command;	return TCL_OK;    } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)	    && (length >= 2)) {	if (argc != 2) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " cmdcount\"", (char *) NULL);	    return TCL_ERROR;	}	sprintf(iPtr->result, "%d", iPtr->cmdCount);	return TCL_OK;    } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)	    && (length >= 4)) {	if (argc > 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " commands [pattern]\"", (char *) NULL);	    return TCL_ERROR;	}	for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {	    char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {		continue;	    }	    Tcl_AppendElement(interp, name, 0);	}	return TCL_OK;    } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)	    && (length >= 4)) {	if (argc != 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " complete command\"", (char *) NULL);	    return TCL_ERROR;	}	if (Tcl_CommandComplete(argv[2])) {	    interp->result = "1";	} else {	    interp->result = "0";	}	return TCL_OK;    } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {	if (argc != 5) {	    Tcl_AppendResult(interp, "wrong # args: should be \"",		    argv[0], " default procname arg varname\"",		    (char *) NULL);	    return TCL_ERROR;	}	procPtr = TclFindProc(iPtr, argv[2]);	if (procPtr == NULL) {	    goto infoNoSuchProc;	}	for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {	    if (argPtr == NULL) {		Tcl_AppendResult(interp, "procedure \"", argv[2],			"\" doesn't have an argument \"", argv[3],			"\"", (char *) NULL);		return TCL_ERROR;	    }	    if (strcmp(argv[3], argPtr->name) == 0) {		if (argPtr->defValue != NULL) {		    if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],			    argPtr->defValue, 0) == NULL) {			defStoreError:			Tcl_AppendResult(interp,				"couldn't store default value in variable \"",				argv[4], "\"", (char *) NULL);			return TCL_ERROR;		    }		    iPtr->result = "1";		} else {		    if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)			    == NULL) {			goto defStoreError;		    }		    iPtr->result = "0";		}		return TCL_OK;	    }	}    } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {	char *p;	if (argc != 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " exists varName\"", (char *) NULL);	    return TCL_ERROR;	}	p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);	/*	 * The code below handles the special case where the name is for	 * an array:  Tcl_GetVar will reject this since you can't read	 * an array variable without an index.	 */	if (p == NULL) {	    Tcl_HashEntry *hPtr;	    Var *varPtr;	    if (strchr(argv[2], '(') != NULL) {		noVar:		iPtr->result = "0";		return TCL_OK;	    }	    if (iPtr->varFramePtr == NULL) {		hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);	    } else {		hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);	    }	    if (hPtr == NULL) {		goto noVar;	    }	    varPtr = (Var *) Tcl_GetHashValue(hPtr);	    if (varPtr->flags & VAR_UPVAR) {		varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);	    }	    if (!(varPtr->flags & VAR_ARRAY)) {		goto noVar;	    }	}	iPtr->result = "1";	return TCL_OK;    } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {	char *name;	if (argc > 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " globals [pattern]\"", (char *) NULL);	    return TCL_ERROR;	}	for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {	    varPtr = (Var *) Tcl_GetHashValue(hPtr);	    if (varPtr->flags & VAR_UNDEFINED) {		continue;	    }	    name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {		continue;	    }	    Tcl_AppendElement(interp, name, 0);	}	return TCL_OK;    } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)	    && (length >= 2)) {	if (argc == 2) {	    if (iPtr->varFramePtr == NULL) {		iPtr->result = "0";	    } else {		sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);	    }	    return TCL_OK;	} else if (argc == 3) {	    long level;	    CallFrame *framePtr;	    if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {		return TCL_ERROR;	    }	    if (level <= 0) {		if (iPtr->varFramePtr == NULL) {		    levelError:		    Tcl_AppendResult(interp, "bad level \"", argv[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;	    }	    iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);	    iPtr->freeProc = (Tcl_FreeProc *) free;	    return TCL_OK;	}	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		" level [number]\"", (char *) NULL);	return TCL_ERROR;    } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)	    && (length >= 2)) {	if (argc != 2) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " library\"", (char *) NULL);	    return TCL_ERROR;	}	interp->result = getenv("TCL_LIBRARY");	if (interp->result == NULL) {#ifdef TCL_LIBRARY	    interp->result = TCL_LIBRARY;#else	    interp->result = "there is no Tcl library at this installation";	    return TCL_ERROR;#endif	}	return TCL_OK;    } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)	    && (length >= 2)) {	char *name;	if (argc > 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " locals [pattern]\"", (char *) NULL);	    return TCL_ERROR;	}	if (iPtr->varFramePtr == NULL) {	    return TCL_OK;	}	for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {	    varPtr = (Var *) Tcl_GetHashValue(hPtr);	    if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {		continue;	    }	    name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {		continue;	    }	    Tcl_AppendElement(interp, name, 0);	}	return TCL_OK;    } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {	if (argc > 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],		    " procs [pattern]\"", (char *) NULL);	    return TCL_ERROR;	}	for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {	    char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);	    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);	    if (!TclIsProc(cmdPtr)) {		continue;	    }	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {		continue;	    }	    Tcl_AppendElement(interp, name, 0);	}	return TCL_OK;    } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {	if (argc != 2) {	    Tcl_AppendResult(interp, "wrong # args: should be \"",		    argv[0], " script\"", (char *) NULL);	    return TCL_ERROR;	}	if (iPtr->scriptFile != NULL) {	    interp->result = iPtr->scriptFile;	}	return TCL_OK;    } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {	if (argc != 2) {	    Tcl_AppendResult(interp, "wrong # args: should be \"",		    argv[0], " tclversion\"", (char *) NULL);	    return TCL_ERROR;	}	/*	 * Note:  TCL_VERSION below is expected to be set with a "-D"	 * switch in the Makefile.	 */	strcpy(iPtr->result, TCL_VERSION);	return TCL_OK;    } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {	Tcl_HashTable *tablePtr;	char *name;	if (argc > 3) {	    Tcl_AppendResult(interp, "wrong # args: should be \"",		    argv[0], " vars [pattern]\"", (char *) NULL);	    return TCL_ERROR;	}	if (iPtr->varFramePtr == NULL) {	    tablePtr = &iPtr->globalTable;	} else {	    tablePtr = &iPtr->varFramePtr->varTable;	}	for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {	    varPtr = (Var *) Tcl_GetHashValue(hPtr);	    if (varPtr->flags & VAR_UNDEFINED) {		continue;	    }	    name = Tcl_GetHashKey(tablePtr, hPtr);	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {		continue;	    }	    Tcl_AppendElement(interp, name, 0);	}	return TCL_OK;    } else {	Tcl_AppendResult(interp, "bad option \"", argv[1],		"\": should be args, body, cmdcount, commands, ",		"complete, default, ",		"exists, globals, level, library, locals, procs, ",		"script, tclversion, or vars",		(char *) NULL);	return TCL_ERROR;    }}/* *---------------------------------------------------------------------- * * Tcl_JoinCmd -- * *	This procedure is invoked to process the "join" Tcl command. *	See the user documentation for details on what it does. * * Results: *	A standard Tcl result. * * Side effects: *	See the user documentation. * *---------------------------------------------------------------------- */	/* ARGSUSED */intTcl_JoinCmd(dummy, interp, argc, argv)    ClientData dummy;			/* Not used. */    Tcl_Interp *interp;			/* Current interpreter. */