diff options
Diffstat (limited to 'vendor/x11iraf/obm/Tcl/tclUnixAZ.c')
| -rw-r--r-- | vendor/x11iraf/obm/Tcl/tclUnixAZ.c | 1998 |
1 files changed, 1998 insertions, 0 deletions
diff --git a/vendor/x11iraf/obm/Tcl/tclUnixAZ.c b/vendor/x11iraf/obm/Tcl/tclUnixAZ.c new file mode 100644 index 00000000..765b7f03 --- /dev/null +++ b/vendor/x11iraf/obm/Tcl/tclUnixAZ.c @@ -0,0 +1,1998 @@ +/* + * tclUnixAZ.c -- + * + * This file contains the top-level command procedures for + * commands in the Tcl core that require UNIX facilities + * such as files and process execution. Much of the code + * in this file is based on earlier versions contributed + * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1993 The Regents of the University of California. + * All rights reserved. + * + * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR + * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT + * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF + * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO + * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. + */ + +#ifndef lint +static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.70 93/09/24 16:47:39 ouster Exp $ SPRITE (Berkeley)"; +#endif /* not lint */ + +#include "tclInt.h" +#include "tclUnix.h" + +/* + * The variable below caches the name of the current working directory + * in order to avoid repeated calls to getcwd. The string is malloc-ed. + * NULL means the cache needs to be refreshed. + */ + +static char *currentDir = NULL; + +/* + * If the system doesn't define the EWOULDBLOCK errno, just #define it + * to a bogus value that will never occur. + */ + +#ifndef EWOULDBLOCK +#define EWOULDBLOCK -1901 +#endif + +/* + * Prototypes for local procedures defined in this file: + */ + +static int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, int *pidPtr, int errorId, + int keepNewline)); +static char * GetFileType _ANSI_ARGS_((int mode)); +static char * GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *modePtr)); +static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, + char *varName, struct stat *statPtr)); + +/* + *---------------------------------------------------------------------- + * + * 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 +Tcl_CdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *dirName; + Tcl_DString buffer; + int result; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " dirName\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 2) { + dirName = argv[1]; + } else { + dirName = "~"; + } + dirName = Tcl_TildeSubst(interp, dirName, &buffer); + if (dirName == NULL) { + return TCL_ERROR; + } + if (currentDir != NULL) { + ckfree(currentDir); + currentDir = NULL; + } + result = TCL_OK; + if (chdir(dirName) != 0) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + } + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseCmd -- + * + * This procedure is invoked to process the "close" 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 +Tcl_CloseCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + OpenFile *oFilePtr; + int result = TCL_OK; + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + oFilePtr = tclOpenFiles[fileno(f)]; + tclOpenFiles[fileno(f)] = NULL; + + /* + * First close the file (in the case of a process pipeline, there may + * be two files, one for the pipe at each end of the pipeline). + */ + + if (oFilePtr->f2 != NULL) { + clearerr(oFilePtr->f2); + if (fclose(oFilePtr->f2) == EOF) { + Tcl_AppendResult(interp, "error closing \"", argv[1], + "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); + result = TCL_ERROR; + } + } + clearerr(oFilePtr->f); + if (fclose(oFilePtr->f) == EOF) { + Tcl_AppendResult(interp, "error closing \"", argv[1], + "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); + result = TCL_ERROR; + } + + /* + * If the file was a connection to a pipeline, clean up everything + * associated with the child processes. + */ + + if (oFilePtr->numPids > 0) { + if (CleanupChildren(interp, oFilePtr->numPids, oFilePtr->pidPtr, + oFilePtr->errorId, 0) != TCL_OK) { + result = TCL_ERROR; + } + } + + ckfree((char *) oFilePtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofCmd -- + * + * This procedure is invoked to process the "eof" 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 +Tcl_EofCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + if (feof(f)) { + interp->result = "1"; + } else { + interp->result = "0"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecCmd -- + * + * This procedure is invoked to process the "exec" 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 +Tcl_ExecCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int outputId; /* File id for output pipe. -1 + * means command overrode. */ + int errorId; /* File id for temporary file + * containing error output. */ + int *pidPtr; + int numPids, result, keepNewline; + int firstWord; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); + firstWord++) { + if (strcmp(argv[firstWord], "-keepnewline") == 0) { + keepNewline = 1; + } else if (strcmp(argv[firstWord], "--") == 0) { + firstWord++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], + "\": must be -keepnewline or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc <= firstWord) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background; if so, create + * the command, detach it, and return a list of pids. + */ + + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + int i; + char id[50]; + + argc--; + argv[argc] = NULL; + numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, + &pidPtr, (int *) NULL, (int *) NULL, (int *) NULL); + if (numPids < 0) { + return TCL_ERROR; + } + Tcl_DetachPids(numPids, pidPtr); + for (i = 0; i < numPids; i++) { + sprintf(id, "%d", pidPtr[i]); + Tcl_AppendElement(interp, id); + } + ckfree((char *) pidPtr); + return TCL_OK; + } + + /* + * Create the command's pipeline. + */ + + numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, + &pidPtr, (int *) NULL, &outputId, &errorId); + if (numPids < 0) { + return TCL_ERROR; + } + + /* + * Read the child's output (if any) and put it into the result. + */ + + result = TCL_OK; + if (outputId != -1) { + while (1) { +# define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = read(outputId, buffer, (size_t) BUFFER_SIZE); + + if (count == 0) { + break; + } + if (count < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, + "error reading from output pipe: ", + Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + } + close(outputId); + } + + if (CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) + != TCL_OK) { + result = TCL_ERROR; + } + 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 +Tcl_ExitCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if ((argc != 1) && (argc != 2)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?returnCode?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + exit(0); + } + if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { + return TCL_ERROR; + } + exit(value); + /*NOTREACHED*/ + return TCL_OK; /* Better not ever reach this! */ +} + +/* + *---------------------------------------------------------------------- + * + * 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 +Tcl_FileCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *p; + int length, statOp, result; + int mode = 0; /* Initialized only to prevent + * compiler warning message. */ + struct stat statBuf; + char *fileName, c; + Tcl_DString buffer; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option name ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + c = argv[1][0]; + length = strlen(argv[1]); + result = TCL_OK; + + /* + * First handle operations on the file name. + */ + + fileName = Tcl_TildeSubst(interp, argv[2], &buffer); + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { + if (argc != 3) { + argv[1] = "dirname"; + not3Args: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ", argv[1], " name\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + p = strrchr(fileName, '/'); + if (p == NULL) { + interp->result = "."; + } else if (p == fileName) { + interp->result = "/"; + } else { + *p = 0; + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + *p = '/'; + } + goto done; + } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) + && (length >= 2)) { + char *lastSlash; + + if (argc != 3) { + argv[1] = "rootname"; + goto not3Args; + } + p = strrchr(fileName, '.'); + lastSlash = strrchr(fileName, '/'); + if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) { + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + } else { + *p = 0; + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + *p = '.'; + } + goto done; + } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) + && (length >= 3)) { + char *lastSlash; + + if (argc != 3) { + argv[1] = "extension"; + goto not3Args; + } + p = strrchr(fileName, '.'); + lastSlash = strrchr(fileName, '/'); + if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) { + Tcl_SetResult(interp, p, TCL_VOLATILE); + } + goto done; + } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "tail"; + goto not3Args; + } + p = strrchr(fileName, '/'); + if (p != NULL) { + Tcl_SetResult(interp, p+1, TCL_VOLATILE); + } else { + Tcl_SetResult(interp, fileName, TCL_VOLATILE); + } + goto done; + } + + /* + * Next, handle operations that can be satisfied with the "access" + * kernel call. + */ + + if (fileName == NULL) { + result = TCL_ERROR; + goto done; + } + if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0) + && (length >= 5)) { + if (argc != 3) { + argv[1] = "readable"; + goto not3Args; + } + mode = R_OK; + checkAccess: + if (access(fileName, mode) == -1) { + interp->result = "0"; + } else { + interp->result = "1"; + } + goto done; + } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) { + if (argc != 3) { + argv[1] = "writable"; + goto not3Args; + } + mode = W_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "executable"; + goto not3Args; + } + mode = X_OK; + goto checkAccess; + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "exists"; + goto not3Args; + } + mode = F_OK; + goto checkAccess; + } + + /* + * Lastly, check stuff that requires the file to be stat-ed. + */ + + if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) { + if (argc != 3) { + argv[1] = "atime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_atime); + goto done; + } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isdirectory"; + goto not3Args; + } + statOp = 2; + } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0) + && (length >= 3)) { + if (argc != 3) { + argv[1] = "isfile"; + goto not3Args; + } + statOp = 1; + } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " lstat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (lstat(fileName, &statBuf) == -1) { + Tcl_AppendResult(interp, "couldn't lstat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) { + if (argc != 3) { + argv[1] = "mtime"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_mtime); + goto done; + } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) { + if (argc != 3) { + argv[1] = "owned"; + goto not3Args; + } + statOp = 0; + } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0) + && (length >= 5)) { + char linkValue[MAXPATHLEN+1]; + int linkLength; + + if (argc != 3) { + argv[1] = "readlink"; + 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; + errno = EINVAL; +#else + linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); +#endif /* S_IFLNK */ + if (linkLength == -1) { + Tcl_AppendResult(interp, "couldn't readlink \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + linkValue[linkLength] = 0; + Tcl_SetResult(interp, linkValue, TCL_VOLATILE); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "size"; + goto not3Args; + } + if (stat(fileName, &statBuf) == -1) { + goto badStat; + } + sprintf(interp->result, "%ld", statBuf.st_size); + goto done; + } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " stat name varName\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + + if (stat(fileName, &statBuf) == -1) { + badStat: + Tcl_AppendResult(interp, "couldn't stat \"", argv[2], + "\": ", Tcl_PosixError(interp), (char *) NULL); + result = TCL_ERROR; + goto done; + } + result = StoreStatData(interp, argv[3], &statBuf); + goto done; + } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0) + && (length >= 2)) { + if (argc != 3) { + argv[1] = "type"; + goto not3Args; + } + if (lstat(fileName, &statBuf) == -1) { + goto badStat; + } + interp->result = GetFileType((int) statBuf.st_mode); + goto done; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be atime, dirname, executable, exists, ", + "extension, isdirectory, isfile, lstat, mtime, owned, ", + "readable, readlink, ", + "root, size, stat, tail, type, ", + "or writable", + (char *) NULL); + result = TCL_ERROR; + goto done; + } + if (stat(fileName, &statBuf) == -1) { + interp->result = "0"; + goto done; + } + switch (statOp) { + case 0: + mode = (geteuid() == statBuf.st_uid); + break; + case 1: + mode = S_ISREG(statBuf.st_mode); + break; + case 2: + mode = S_ISDIR(statBuf.st_mode); + break; + } + if (mode) { + interp->result = "1"; + } else { + interp->result = "0"; + } + + done: + Tcl_DStringFree(&buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * 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 +StoreStatData(interp, varName, statPtr) + Tcl_Interp *interp; /* Interpreter for error reports. */ + char *varName; /* Name of associative array variable + * in which to store stat results. */ + struct stat *statPtr; /* Pointer to buffer containing + * stat data to store in varName. */ +{ + char string[30]; + + sprintf(string, "%d", statPtr->st_dev); + if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_ino); + if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_mode); + if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_nlink); + if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_uid); + if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%d", statPtr->st_gid); + if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_size); + if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_atime); + if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_mtime); + if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + sprintf(string, "%ld", statPtr->st_ctime); + if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + if (Tcl_SetVar2(interp, varName, "type", + GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetFileType -- + * + * 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 * +GetFileType(mode) + int mode; +{ + if (S_ISREG(mode)) { + return "file"; + } else if (S_ISDIR(mode)) { + return "directory"; + } else if (S_ISCHR(mode)) { + return "characterSpecial"; + } else if (S_ISBLK(mode)) { + return "blockSpecial"; + } else if (S_ISFIFO(mode)) { + return "fifo"; + } else if (S_ISLNK(mode)) { + return "link"; + } else if (S_ISSOCK(mode)) { + return "socket"; + } + return "unknown"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushCmd -- + * + * This procedure is invoked to process the "flush" 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 +Tcl_FlushCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 1, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + clearerr(f); + if (fflush(f) == EOF) { + Tcl_AppendResult(interp, "error flushing \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsCmd -- + * + * This procedure is invoked to process the "gets" 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 +Tcl_GetsCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +# define BUF_SIZE 200 + char buffer[BUF_SIZE+1]; + int totalCount, done, flags; + FILE *f; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + /* + * We can't predict how large a line will be, so read it in + * pieces, appending to the current result or to a variable. + */ + + totalCount = 0; + done = 0; + flags = 0; + clearerr(f); + while (!done) { + register int c, count; + register char *p; + + for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) { + c = getc(f); + if (c == EOF) { + if (ferror(f)) { + /* + * If the file is in non-blocking mode, return any + * bytes that were read before a block would occur. + */ + + if ((errno == EWOULDBLOCK) + && ((count > 0 || totalCount > 0))) { + done = 1; + break; + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } else if (feof(f)) { + if ((totalCount == 0) && (count == 0)) { + totalCount = -1; + } + done = 1; + break; + } + } + if (c == '\n') { + done = 1; + break; + } + *p = c; + } + *p = 0; + if (argc == 2) { + Tcl_AppendResult(interp, buffer, (char *) NULL); + } else { + if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG) + == NULL) { + return TCL_ERROR; + } + flags = TCL_APPEND_VALUE; + } + totalCount += count; + } + + if (argc == 3) { + sprintf(interp->result, "%d", totalCount); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCmd -- + * + * This procedure is invoked to process the "open" 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 +Tcl_OpenCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int pipeline, fd, mode, prot, readWrite, permissions; + char *access; + FILE *f, *f2; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " filename ?access? ?permissions?\"", (char *) NULL); + return TCL_ERROR; + } + prot = 0666; + if (argc == 2) { + mode = O_RDONLY; + access = "r"; + } else { + access = GetOpenMode(interp, argv[2], &mode); + if (access == NULL) { + return TCL_ERROR; + } + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + f = f2 = NULL; + readWrite = mode & (O_RDWR|O_RDONLY|O_WRONLY); + if (readWrite == O_RDONLY) { + permissions = TCL_FILE_READABLE; + } else if (readWrite == O_WRONLY) { + permissions = TCL_FILE_WRITABLE; + } else { + permissions = TCL_FILE_READABLE|TCL_FILE_WRITABLE; + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + char *fileName; + Tcl_DString buffer; + + fileName = Tcl_TildeSubst(interp, argv[1], &buffer); + if (fileName == NULL) { + return TCL_ERROR; + } + fd = open(fileName, mode, prot); + Tcl_DStringFree(&buffer); + if (fd < 0) { + Tcl_AppendResult(interp, "couldn't open \"", argv[1], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + f = fdopen(fd, access); + if (f == NULL) { + close(fd); + return TCL_ERROR; + } + Tcl_EnterFile(interp, f, permissions); + } else { + int *inPipePtr, *outPipePtr; + int cmdArgc, inPipe, outPipe, numPids, *pidPtr, errorId; + char **cmdArgv; + OpenFile *oFilePtr; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + inPipePtr = (permissions & TCL_FILE_WRITABLE) ? &inPipe : NULL; + outPipePtr = (permissions & TCL_FILE_READABLE) ? &outPipe : NULL; + inPipe = outPipe = errorId = -1; + numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv, + &pidPtr, inPipePtr, outPipePtr, &errorId); + ckfree((char *) cmdArgv); + if (numPids < 0) { + pipelineError: + if (f != NULL) { + fclose(f); + } + if (f2 != NULL) { + fclose(f2); + } + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (errorId != -1) { + close(errorId); + } + return TCL_ERROR; + } + if (permissions & TCL_FILE_READABLE) { + if (outPipe == -1) { + if (inPipe != -1) { + close(inPipe); + } + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto pipelineError; + } + f = fdopen(outPipe, "r"); + } + if (permissions & TCL_FILE_WRITABLE) { + if (inPipe == -1) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto pipelineError; + } + if (f != NULL) { + f2 = fdopen(inPipe, "w"); + } else { + f = fdopen(inPipe, "w"); + } + } + Tcl_EnterFile(interp, f, permissions); + oFilePtr = tclOpenFiles[fileno(f)]; + oFilePtr->f2 = f2; + oFilePtr->numPids = numPids; + oFilePtr->pidPtr = pidPtr; + oFilePtr->errorId = errorId; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetOpenMode -- + * + * description. + * + * Results: + * Normally, sets *modePtr to an access mode for passing to "open", + * and returns a string that can be used as the access mode in a + * subsequent call to "fdopen". If an error occurs, then returns + * NULL and sets interp->result to an error message. + * + * Side effects: + * None. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +static char * +GetOpenMode(interp, string, modePtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ + int *modePtr; /* Where to store mode corresponding + * to string. */ +{ + int mode, modeArgc, c, i, gotRW; + char **modeArgv, *flag; +#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) + + /* + * Check for the simpler fopen-like access modes (e.g. "r"). They + * are distinguished from the POSIX access modes by the presence + * of a lower-case first letter. + */ + + mode = 0; + if (islower(UCHAR(string[0]))) { + switch (string[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT|O_APPEND; + break; + default: + error: + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", (char *) NULL); + return NULL; + } + if (string[1] == '+') { + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + *modePtr = mode; + return string; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as O_CREAT. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + return NULL; + } + gotRW = 0; + for (i = 0; i < modeArgc; i++) { + flag = modeArgv[i]; + c = flag[0]; + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_RDONLY; + gotRW = 1; + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_WRONLY; + gotRW = 1; + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { + mode = (mode & ~RW_MODES) | O_RDWR; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= O_APPEND; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= O_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { +#ifdef O_NOCTTY + mode |= O_NOCTTY; +#else + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + ckfree((char *) modeArgv); + return NULL; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#ifdef O_NONBLOCK + mode |= O_NONBLOCK; +#else + mode |= O_NDELAY; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_TRUNC; + } else { + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", + " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); + ckfree((char *) modeArgv); + return NULL; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + return NULL; + } + *modePtr = mode; + + /* + * The calculation of fdopen access mode below isn't really correct, + * but it doesn't have to be. All it has to do is to disinguish + * read and write permissions, plus indicate append mode. + */ + + i = mode & RW_MODES; + if (i == O_RDONLY) { + return "r"; + } + if (mode & O_APPEND) { + if (i == O_WRONLY) { + return "a"; + } else { + return "a+"; + } + } + if (i == O_WRONLY) { + return "w"; + } + return "r+"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidCmd -- + * + * This procedure is invoked to process the "pid" 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 +Tcl_PidCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + OpenFile *oFilePtr; + int i; + char string[50]; + + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ?fileId?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 1) { + sprintf(interp->result, "%d", getpid()); + } else { + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + oFilePtr = tclOpenFiles[fileno(f)]; + for (i = 0; i < oFilePtr->numPids; i++) { + sprintf(string, "%d", oFilePtr->pidPtr[i]); + Tcl_AppendElement(interp, string); + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsCmd -- + * + * This procedure is invoked to process the "puts" 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 +Tcl_PutsCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + int i, newline; + char *fileId; + + i = 1; + newline = 1; + if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if ((i < (argc-3)) || (i >= argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + "\" ?-nonewline? ?fileId? string", (char *) NULL); + return TCL_ERROR; + } + + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or documented. + */ + + if (i == (argc-3)) { + if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[i+2], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + newline = 0; + } + if (i == (argc-1)) { + fileId = "stdout"; + } else { + fileId = argv[i]; + i++; + } + + if (Tcl_GetOpenFile(interp, fileId, 1, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + clearerr(f); + fputs(argv[i], f); + if (newline) { + fputc('\n', f); + } + if (ferror(f)) { + Tcl_AppendResult(interp, "error writing \"", fileId, + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PwdCmd -- + * + * This procedure is invoked to process the "pwd" 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 +Tcl_PwdCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char buffer[MAXPATHLEN+1]; + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], "\"", (char *) NULL); + return TCL_ERROR; + } + if (currentDir == NULL) { + if (getcwd(buffer, MAXPATHLEN+1) == NULL) { + if (errno == ERANGE) { + interp->result = "working directory name is too long"; + } else { + Tcl_AppendResult(interp, + "error getting working directory name: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); + strcpy(currentDir, buffer); + } + interp->result = currentDir; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadCmd -- + * + * This procedure is invoked to process the "read" 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 +Tcl_ReadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int bytesLeft, bytesRead, count; +#define READ_BUF_SIZE 4096 + char buffer[READ_BUF_SIZE+1]; + int newline, i; + FILE *f; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId ?numBytes?\" or \"", argv[0], + " ?-nonewline? fileId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 1; + if ((argc == 3) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if (Tcl_GetOpenFile(interp, argv[i], 0, 1, &f) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + if ((argc >= (i + 2)) && isdigit(UCHAR(argv[i+1][0]))) { + if (Tcl_GetInt(interp, argv[i+1], &bytesLeft) != TCL_OK) { + return TCL_ERROR; + } + } else { + bytesLeft = 1<<30; + + /* + * The code below provides backward compatibility for an + * archaic earlier version of this command. + */ + + if (argc >= (i + 2)) { + if (strncmp(argv[i+1], "nonewline", strlen(argv[i+1])) == 0) { + newline = 0; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[i+1], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + } + + /* + * Read the file in one or more chunks. + */ + + bytesRead = 0; + clearerr(f); + while (bytesLeft > 0) { + count = READ_BUF_SIZE; + if (bytesLeft < READ_BUF_SIZE) { + count = bytesLeft; + } + count = fread(buffer, 1, count, f); + if (ferror(f)) { + /* + * If the file is in non-blocking mode, break out of the + * loop and return any bytes that were read. + */ + + if ((errno == EWOULDBLOCK) && ((count > 0) || (bytesRead > 0))) { + clearerr(f); + bytesLeft = count; + } else { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", argv[i], + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + if (count == 0) { + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + bytesLeft -= count; + bytesRead += count; + } + if ((newline == 0) && (bytesRead > 0) + && (interp->result[bytesRead-1] == '\n')) { + interp->result[bytesRead-1] = 0; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the "seek" 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 +Tcl_SeekCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + int offset, mode; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + int length; + char c; + + length = strlen(argv[3]); + c = argv[3][0]; + if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { + mode = SEEK_SET; + } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { + mode = SEEK_CUR; + } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { + mode = SEEK_END; + } else { + Tcl_AppendResult(interp, "bad origin \"", argv[3], + "\": should be start, current, or end", (char *) NULL); + return TCL_ERROR; + } + } + clearerr(f); + if (fseek(f, (long) offset, mode) == -1) { + Tcl_AppendResult(interp, "error during seek: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SourceCmd -- + * + * This procedure is invoked to process the "source" 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 +Tcl_SourceCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_EvalFile(interp, argv[1]); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the "tell" 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 +Tcl_TellCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + FILE *f; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileId\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", ftell(f)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TimeCmd -- + * + * This procedure is invoked to process the "time" 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 +Tcl_TimeCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count, i, result; + double timePer; +#if NO_GETTOD + struct tms dummy2; + long start, stop; +#else + struct timeval start, stop; + struct timezone tz; + int micros; +#endif + + if (argc == 2) { + count = 1; + } else if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " command ?count?\"", (char *) NULL); + return TCL_ERROR; + } +#if NO_GETTOD + start = times(&dummy2); +#else + gettimeofday(&start, &tz); +#endif + for (i = count ; i > 0; i--) { + result = Tcl_Eval(interp, argv[1]); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"time\" body line %d)", + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + return result; + } + } +#if NO_GETTOD + stop = times(&dummy2); + timePer = (((double) (stop - start))*1000000.0)/CLK_TCK; +#else + gettimeofday(&stop, &tz); + micros = (stop.tv_sec - start.tv_sec)*1000000 + + (stop.tv_usec - start.tv_usec); + timePer = micros; +#endif + Tcl_ResetResult(interp); + sprintf(interp->result, "%.0f microseconds per iteration", timePer/count); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupChildren -- + * + * This is a utility procedure used to wait for child processes + * to exit, record information about abnormal exits, and then + * collect any stderr output generated by them. + * + * Results: + * The return value is a standard Tcl result. If anything at + * weird happened with the child processes, TCL_ERROR is returned + * and a message is left in interp->result. + * + * Side effects: + * If the last character of interp->result is a newline, then it + * is removed unless keepNewline is non-zero. File errorId gets + * closed, and pidPtr is freed back to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static int +CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + int *pidPtr; /* Array of process ids of children. */ + int errorId; /* File descriptor index for file containing + * stderr output from pipeline. -1 means + * there isn't any stderr output. */ + int keepNewline; /* Non-zero means don't discard trailing + * newline. */ +{ + int result = TCL_OK; + int i, pid, length, abnormalExit; + WAIT_STATUS_TYPE waitStatus; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = waitpid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == -1) { + Tcl_AppendResult(interp, "error waiting for process to exit: ", + Tcl_PosixError(interp), (char *) NULL); + continue; + } + + /* + * Create error messages for unusual process exits. An + * extra newline gets appended to each error message, but + * it gets removed below (in the same fashion that an + * extra newline in the command's output is removed). + */ + + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[20], msg2[20]; + + result = TCL_ERROR; + sprintf(msg1, "%d", pid); + if (WIFEXITED(waitStatus)) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + char *p; + + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + (char *) NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", + (char *) NULL); + } else if (WIFSTOPPED(waitStatus)) { + char *p; + + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + (char *) NULL); + } else { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + ckfree((char *) pidPtr); + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + if (errorId >= 0) { + while (1) { +# define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = read(errorId, buffer, (size_t) BUFFER_SIZE); + + if (count == 0) { + break; + } + result = TCL_ERROR; + if (count < 0) { + Tcl_AppendResult(interp, + "error reading stderr output file: ", + Tcl_PosixError(interp), (char *) NULL); + break; + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + } + close(errorId); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && (*interp->result == 0)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + /* + * If the last character of interp->result is a newline, then remove + * the newline character (the newline would just confuse things). + * Special hack: must replace the old terminating null character + * as a signal to Tcl_AppendResult et al. that we've mucked with + * the string. + */ + + length = strlen(interp->result); + if (!keepNewline && (length > 0) && (interp->result[length-1] == '\n')) { + interp->result[length-1] = '\0'; + interp->result[length] = 'x'; + } + + return result; +} |