/*
* tclCmdAH.c --
*
* This file contains the top-level command routines for most of
* the Tcl built-in commands whose names begin with the letters
* A to H.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclCmdAH.c 1.111 96/07/30 09:33:59
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* Prototypes for local procedures defined in this file:
*/
/*
*----------------------------------------------------------------------
*
* Tcl_BreakCmd --
*
* This procedure is invoked to process the "break" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 1) {
return TCL_ERROR;
}
return TCL_BREAK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CaseCmd --
*
* This procedure is invoked to process the "case" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i, result;
int body;
char *string;
char **caseArgv;
if (argc < 3) {
argv[0], " string ?in? patList body ... ?default body?\"",
(char *) NULL);
return TCL_ERROR;
}
body = -1;
i = 3;
} else {
i = 2;
}
/*
* argument, split them out again.
*/
splitArgs = 0;
if (caseArgc == 1) {
return result;
}
splitArgs = 1;
}
for (i = 0; i < caseArgc; i += 2) {
int patArgc, j;
char **patArgv;
register char *p;
if (i == (caseArgc-1)) {
goto cleanup;
}
/*
* Check for special case of single pattern (no list) with
* no backslash sequences.
*/
for (p = caseArgv[i]; *p != 0; p++) {
break;
}
}
if (*p == 0) {
if ((*caseArgv[i] == 'd')
body = i+1;
}
body = i+1;
goto match;
}
continue;
}
/*
* Break up pattern lists, then check each of the patterns
* in the list.
*/
goto cleanup;
}
for (j = 0; j < patArgc; j++) {
body = i+1;
break;
}
}
if (j < patArgc) {
break;
}
}
if (body != -1) {
}
goto cleanup;
}
/*
* Nothing matched: return nothing.
*/
if (splitArgs) {
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CatchCmd --
*
* This procedure is invoked to process the "catch" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int result;
return TCL_ERROR;
}
if (argc == 3) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CdCmd --
*
* This procedure is invoked to process the "cd" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
char *dirName;
int result;
if (argc > 2) {
" dirName\"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 2) {
} else {
dirName = "~";
}
return TCL_ERROR;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConcatCmd --
*
* This procedure is invoked to process the "concat" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc >= 2) {
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ContinueCmd --
*
* This procedure is invoked to process the "continue" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 1) {
"\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ErrorCmd --
*
* This procedure is invoked to process the "error" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
" message ?errorInfo? ?errorCode?\"", (char *) NULL);
return TCL_ERROR;
}
}
if (argc == 4) {
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalCmd --
*
* This procedure is invoked to process the "eval" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int result;
char *cmd;
if (argc < 2) {
" arg ?arg ...?\"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 2) {
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result.
*/
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExitCmd --
*
* This procedure is invoked to process the "exit" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int value;
" ?returnCode?\"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 1) {
value = 0;
return TCL_ERROR;
}
/*NOTREACHED*/
return TCL_OK; /* Better not ever reach this! */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExprCmd --
*
* This procedure is invoked to process the "expr" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i, result;
if (argc < 2) {
" arg ?arg ...?\"", (char *) NULL);
return TCL_ERROR;
}
if (argc == 2) {
}
for (i = 2; i < argc; i++) {
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FileCmd --
*
* This procedure is invoked to process the "file" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
* compiler warning message. */
if (argc < 3) {
" option name ?arg ...?\"", (char *) NULL);
return TCL_ERROR;
}
c = argv[1][0];
/*
* First handle operations on the file name.
*/
int pargc;
char **pargv;
if (argc != 3) {
goto not3Args;
}
/*
* If there is only one element, and it starts with a tilde,
* perform tilde substitution and resplit the path.
*/
goto done;
}
Tcl_DStringSetLength(&buffer, 0);
}
/*
* Return all but the last component. If there is only one
* component, return it if the path was non-relative, otherwise
* return the current directory.
*/
if (pargc > 1) {
} else if ((pargc == 0)
#if 0
#else
#endif
} else {
}
goto done;
&& (length >= 2)) {
int pargc;
char **pargv;
if (argc != 3) {
goto not3Args;
}
/*
* If there is only one element, and it starts with a tilde,
* perform tilde substitution and resplit the path.
*/
goto done;
}
Tcl_DStringSetLength(&buffer, 0);
}
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
if (pargc > 0) {
if ((pargc > 1)
}
}
goto done;
&& (length >= 2)) {
char tmp;
if (argc != 3) {
goto not3Args;
}
} else {
*extension = 0;
}
goto done;
&& (length >= 3)) {
if (argc != 3) {
goto not3Args;
}
}
goto done;
if (argc != 3) {
goto not3Args;
}
case TCL_PATH_ABSOLUTE:
break;
case TCL_PATH_RELATIVE:
break;
case TCL_PATH_VOLUME_RELATIVE:
break;
}
goto done;
&& (length >= 2)) {
int pargc, i;
char **pargvList;
if (argc != 3) {
goto not3Args;
}
for (i = 0; i < pargc; i++) {
}
goto done;
goto done;
}
/*
* Next, handle operations that can be satisfied with the "access"
* kernel call.
*/
goto done;
}
&& (length >= 5)) {
if (argc != 3) {
goto not3Args;
}
} else {
}
goto done;
if (argc != 3) {
goto not3Args;
}
goto checkAccess;
&& (length >= 3)) {
if (argc != 3) {
goto not3Args;
}
goto checkAccess;
&& (length >= 3)) {
if (argc != 3) {
goto not3Args;
}
goto checkAccess;
}
/*
* Lastly, check stuff that requires the file to be stat-ed.
*/
if (argc != 3) {
goto not3Args;
}
goto badStat;
}
goto done;
&& (length >= 3)) {
if (argc != 3) {
goto not3Args;
}
statOp = 2;
&& (length >= 3)) {
if (argc != 3) {
goto not3Args;
}
statOp = 1;
if (argc != 4) {
" lstat name varName\"", (char *) NULL);
goto done;
}
goto done;
}
goto done;
if (argc != 3) {
goto not3Args;
}
goto badStat;
}
goto done;
if (argc != 3) {
goto not3Args;
}
statOp = 0;
&& (length >= 5)) {
int linkLength;
if (argc != 3) {
goto not3Args;
}
/*
* If S_IFLNK isn't defined it means that the machine doesn't
* support symbolic links, so the file can't possibly be a
* symbolic link. Generate an EINVAL error, which is what
* happens on machines that do support symbolic links when
* you invoke readlink on a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
linkLength = -1;
#else
#endif /* S_IFLNK */
if (linkLength == -1) {
goto done;
}
linkValue[linkLength] = 0;
goto done;
&& (length >= 2)) {
if (argc != 3) {
goto not3Args;
}
goto badStat;
}
goto done;
&& (length >= 2)) {
if (argc != 4) {
" stat name varName\"", (char *) NULL);
goto done;
}
goto done;
}
goto done;
&& (length >= 2)) {
if (argc != 3) {
goto not3Args;
}
goto badStat;
}
goto done;
} else {
"\": should be atime, dirname, executable, exists, ",
"extension, isdirectory, isfile, join, ",
"lstat, mtime, owned, pathtype, readable, readlink, ",
"root, size, split, stat, tail, type, ",
"or writable",
(char *) NULL);
goto done;
}
goto done;
}
switch (statOp) {
case 0:
/*
* For Windows and Macintosh, there are no user ids
* associated with a file, so we always return 1.
*/
mode = 1;
#else
#endif
break;
case 1:
break;
case 2:
break;
}
if (mode) {
} else {
}
done:
return result;
goto done;
}
/*
*----------------------------------------------------------------------
*
* StoreStatData --
*
* This is a utility procedure that breaks out the fields of a
* "stat" structure and stores them in textual form into the
* elements of an associative array.
*
* Results:
* Returns a standard Tcl return value. If an error occurs then
* a message is left in interp->result.
*
* Side effects:
* Elements of the associative array given by "varName" are modified.
*
*----------------------------------------------------------------------
*/
static int
char *varName; /* Name of associative array variable
* in which to store stat results. */
* stat data to store in varName. */
{
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
== NULL) {
return TCL_ERROR;
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetTypeFromMode --
*
* Given a mode word, returns a string identifying the type of a
* file.
*
* Results:
* A static text string giving the file type from mode.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
int mode;
{
return "file";
return "directory";
return "characterSpecial";
return "blockSpecial";
return "fifo";
return "link";
return "socket";
}
return "unknown";
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForCmd --
*
* This procedure is invoked to process the "for" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
if (argc != 5) {
" start test next command\"", (char *) NULL);
return TCL_ERROR;
}
}
return result;
}
while (1) {
return result;
}
if (!value) {
break;
}
}
break;
}
break;
}
return result;
}
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForeachCmd --
*
* This procedure is invoked to process the "foreach" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i; /* i selects a value list */
int v; /* v selects a loop variable */
" varList list ?varList list ...? command\"", (char *) NULL);
return TCL_ERROR;
}
/*
* Manage numList parallel value lists.
* argvList[i] is a value list counted by argcList[i]
* varvList[i] is the list of variables associated with the value list
* varcList[i] is the number of variables associated with the value list
* index[i] is the current pointer into the value list argvList[i]
*/
if (numLists > STATIC_SIZE) {
}
for (i=0 ; i<numLists ; i++) {
index[i] = 0;
varcList[i] = 0;
argcList[i] = 0;
}
/*
* Break up the value lists and variable lists into elements
*/
maxj = 0;
for (i=0 ; i<numLists ; i++) {
goto errorReturn;
}
goto errorReturn;
}
j++;
}
if (j > maxj) {
maxj = j;
}
}
/*
* Iterate maxj times through the lists in parallel
* If some value lists run out of values, set loop vars to ""
*/
for (j = 0; j < maxj; j++) {
for (i=0 ; i<numLists ; i++) {
for (v=0 ; v<varcList[i] ; v++) {
int k = index[i]++;
if (k < argcList[i]) {
}
goto errorReturn;
}
}
}
if (result == TCL_CONTINUE) {
break;
break;
} else {
break;
}
}
}
}
for (i=0 ; i<numLists ; i++) {
}
}
}
if (numLists > STATIC_SIZE) {
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FormatCmd --
*
* This procedure is invoked to process the "format" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
* string. */
* no width given. */
* if no precision given. */
* conversion, based on type of conversion
* ("e", "s", etc.), width, and precision. */
* it's a one-word integer or char value */
* it's a one-word value. */
* it's a double value. */
* or doubleValue has the value to pass to
* sprintf, according to the following
* definitions: */
# define INT_VALUE 0
* interp->resultSpace, but may get dynamically
* re-allocated if this isn't enough. */
* stored at dst. */
/* Total amount of storage space available
* in dst (not including null terminator. */
* no field specifier, just a string to copy. */
* specifier has been seen. */
* (non-XPG3) conversion specifier has been
* seen. */
/*
* This procedure is a bit nasty. The goal is to use sprintf to
* do most of the dirty work. There are several problems:
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
* 2. there's no way to move the arguments from argv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
if (argc < 2) {
" formatString ?arg arg ...?\"", (char *) NULL);
return TCL_ERROR;
}
argIndex = 2;
/*
* Get rid of any characters before the next field specifier.
*/
if (*format != '%') {
register char *p;
*p = *format;
p++;
format++;
}
noPercent = 1;
goto doField;
}
size = 1;
noPercent = 1;
format += 2;
goto doField;
}
/*
* Parse off a field specifier, compute how many characters
* will be needed to store the result, and substitute for
* "*" size specifiers.
*/
*newPtr = '%';
newPtr++;
format++;
int tmp;
/*
* Check for an XPG3-style %n$ specification. Note: there
* must not be a mixture of XPG3 specs and non-XPG3 specs
* in the same format string.
*/
if (*end != '$') {
goto notXpg;
}
gotXpg = 1;
if (gotSequential) {
goto mixedXPG;
}
goto badIndex;
}
goto xpgCheckDone;
}
gotSequential = 1;
if (gotXpg) {
goto mixedXPG;
}
newPtr++;
format++;
}
} else if (*format == '*') {
goto badIndex;
}
goto fmtError;
}
argIndex++;
format++;
}
if (width > 100000) {
/*
* Don't allow arbitrarily large widths: could cause core
* dump when we try to allocate a zillion bytes of memory
* below.
*/
width = 100000;
} else if (width < 0) {
width = 0;
}
if (width != 0) {
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == '.') {
*newPtr = '.';
newPtr++;
format++;
}
} else if (*format == '*') {
goto badIndex;
}
goto fmtError;
}
argIndex++;
format++;
}
if (precision != 0) {
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == 'l') {
format++;
} else if (*format == 'h') {
useShort = 1;
*newPtr = 'h';
newPtr++;
format++;
}
newPtr++;
*newPtr = 0;
goto badIndex;
}
switch (*format) {
case 'i':
case 'd':
case 'o':
case 'u':
case 'x':
case 'X':
!= TCL_OK) {
goto fmtError;
}
break;
case 's':
break;
case 'c':
!= TCL_OK) {
goto fmtError;
}
size = 1;
break;
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
!= TCL_OK) {
goto fmtError;
}
size = 320;
if (precision > 10) {
}
break;
case 0:
"format string ended in middle of field specifier";
goto fmtError;
default:
goto fmtError;
}
argIndex++;
format++;
/*
* Make sure that there's enough space to hold the formatted
* result, then format it.
*/
}
char *newDst;
int newSpace;
if (dstSize != 0) {
}
if (dstSpace != TCL_RESULT_SIZE) {
}
}
if (noPercent) {
} else {
if (whichValue == DOUBLE_VALUE) {
} else if (whichValue == INT_VALUE) {
if (useShort) {
} else {
}
} else {
}
}
}
if (dstSpace != TCL_RESULT_SIZE) {
} else {
}
return TCL_OK;
goto fmtError;
if (gotXpg) {
} else {
}
if (dstSpace != TCL_RESULT_SIZE) {
}
return TCL_ERROR;
}