home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-11-15 | 42.1 KB | 1,608 lines |
- Newsgroups: comp.sources.misc
- From: karl@sugar.neosoft.com (Karl Lehenbauer)
- Subject: v25i098: tcl - tool command language, version 6.1, Part30/33
- Message-ID: <1991Nov15.225942.22086@sparky.imd.sterling.com>
- X-Md4-Signature: a99451b5c1eed952151d99944982f055
- Date: Fri, 15 Nov 1991 22:59:42 GMT
- Approved: kent@sparky.imd.sterling.com
-
- Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer)
- Posting-number: Volume 25, Issue 98
- Archive-name: tcl/part30
- Environment: UNIX
-
- #! /bin/sh
- # This is a shell archive. Remove anything before this line, then unpack
- # it by saving it into a file and typing "sh file". To overwrite existing
- # files, type "sh file -c". You can also feed this as standard input via
- # unshar, or by typing "sh <file", e.g.. If this archive is complete, you
- # will see the following message at the end:
- # "End of archive 30 (of 33)."
- # Contents: tcl6.1/tclUnixAZ.c
- # Wrapped by karl@one on Tue Nov 12 19:44:32 1991
- PATH=/bin:/usr/bin:/usr/ucb ; export PATH
- if test -f 'tcl6.1/tclUnixAZ.c' -a "${1}" != "-c" ; then
- echo shar: Will not clobber existing file \"'tcl6.1/tclUnixAZ.c'\"
- else
- echo shar: Extracting \"'tcl6.1/tclUnixAZ.c'\" \(39407 characters\)
- sed "s/^X//" >'tcl6.1/tclUnixAZ.c' <<'END_OF_FILE'
- X/*
- X * tclUnixAZ.c --
- X *
- X * This file contains the top-level command procedures for
- X * commands in the Tcl core that require UNIX facilities
- X * such as files and process execution. Much of the code
- X * in this file is based on earlier versions contributed
- X * by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
- X *
- X * Copyright 1991 Regents of the University of California
- X * Permission to use, copy, modify, and distribute this
- X * software and its documentation for any purpose and without
- X * fee is hereby granted, provided that this copyright
- X * notice appears in all copies. The University of California
- X * makes no representations about the suitability of this
- X * software for any purpose. It is provided "as is" without
- X * express or implied warranty.
- X */
- X
- X#ifndef lint
- Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.30 91/11/04 09:56:13 ouster Exp $ SPRITE (Berkeley)";
- X#endif /* not lint */
- X
- X#include "tclInt.h"
- X#include "tclUnix.h"
- X
- X/*
- X * The variable below caches the name of the current working directory
- X * in order to avoid repeated calls to getwd. The string is malloc-ed.
- X * NULL means the cache needs to be refreshed.
- X */
- X
- Xstatic char *currentDir = NULL;
- X
- X/*
- X * Prototypes for local procedures defined in this file:
- X */
- X
- Xstatic int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
- X int numPids, int *pidPtr, int errorId));
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_CdCmd --
- X *
- X * This procedure is invoked to process the "cd" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_CdCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X char *dirName;
- X
- X if (argc > 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " dirName\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X if (argc == 2) {
- X dirName = argv[1];
- X } else {
- X dirName = "~";
- X }
- X dirName = Tcl_TildeSubst(interp, dirName);
- X if (dirName == NULL) {
- X return TCL_ERROR;
- X }
- X if (currentDir != NULL) {
- X ckfree(currentDir);
- X currentDir = NULL;
- X }
- X if (chdir(dirName) != 0) {
- X Tcl_AppendResult(interp, "couldn't change working directory to \"",
- X dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);
- X return TCL_ERROR;
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_CloseCmd --
- X *
- X * This procedure is invoked to process the "close" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_CloseCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X int result = TCL_OK;
- X
- X if (argc != 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X ((Interp *) interp)->filePtrArray[fileno(filePtr->f)] = NULL;
- X
- X /*
- X * First close the file (in the case of a process pipeline, there may
- X * be two files, one for the pipe at each end of the pipeline).
- X */
- X
- X if (filePtr->f2 != NULL) {
- X if (fclose(filePtr->f2) == EOF) {
- X Tcl_AppendResult(interp, "error closing \"", argv[1],
- X "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
- X result = TCL_ERROR;
- X }
- X }
- X if (fclose(filePtr->f) == EOF) {
- X Tcl_AppendResult(interp, "error closing \"", argv[1],
- X "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
- X result = TCL_ERROR;
- X }
- X
- X /*
- X * If the file was a connection to a pipeline, clean up everything
- X * associated with the child processes.
- X */
- X
- X if (filePtr->numPids > 0) {
- X if (CleanupChildren(interp, filePtr->numPids, filePtr->pidPtr,
- X filePtr->errorId) != TCL_OK) {
- X result = TCL_ERROR;
- X }
- X }
- X
- X ckfree((char *) filePtr);
- X return result;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_EofCmd --
- X *
- X * This procedure is invoked to process the "eof" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_EofCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X
- X if (argc != 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (feof(filePtr->f)) {
- X interp->result = "1";
- X } else {
- X interp->result = "0";
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_ExecCmd --
- X *
- X * This procedure is invoked to process the "exec" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_ExecCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int outputId; /* File id for output pipe. -1
- X * means command overrode. */
- X int errorId; /* File id for temporary file
- X * containing error output. */
- X int *pidPtr;
- X int numPids, result;
- X
- X /*
- X * See if the command is to be run in background; if so, create
- X * the command, detach it, and return.
- X */
- X
- X if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
- X argc--;
- X argv[argc] = NULL;
- X numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
- X (int *) NULL, (int *) NULL, (int *) NULL);
- X if (numPids < 0) {
- X return TCL_ERROR;
- X }
- X Tcl_DetachPids(numPids, pidPtr);
- X ckfree((char *) pidPtr);
- X return TCL_OK;
- X }
- X
- X /*
- X * Create the command's pipeline.
- X */
- X
- X numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
- X (int *) NULL, &outputId, &errorId);
- X if (numPids < 0) {
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Read the child's output (if any) and put it into the result.
- X */
- X
- X result = TCL_OK;
- X if (outputId != -1) {
- X while (1) {
- X# define BUFFER_SIZE 1000
- X char buffer[BUFFER_SIZE+1];
- X int count;
- X
- X count = read(outputId, buffer, BUFFER_SIZE);
- X
- X if (count == 0) {
- X break;
- X }
- X if (count < 0) {
- X Tcl_ResetResult(interp);
- X Tcl_AppendResult(interp,
- X "error reading from output pipe: ",
- X Tcl_UnixError(interp), (char *) NULL);
- X result = TCL_ERROR;
- X break;
- X }
- X buffer[count] = 0;
- X Tcl_AppendResult(interp, buffer, (char *) NULL);
- X }
- X close(outputId);
- X }
- X
- X if (CleanupChildren(interp, numPids, pidPtr, errorId) != TCL_OK) {
- X result = TCL_ERROR;
- X }
- X return result;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_ExitCmd --
- X *
- X * This procedure is invoked to process the "exit" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_ExitCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int value;
- X
- X if ((argc != 1) && (argc != 2)) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ?returnCode?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (argc == 1) {
- X exit(0);
- X }
- X if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X exit(value);
- X return TCL_OK; /* Better not ever reach this! */
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_FileCmd --
- X *
- X * This procedure is invoked to process the "file" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_FileCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X char *p;
- X int length, statOp;
- X int mode = 0; /* Initialized only to prevent
- X * compiler warning message. */
- X struct stat statBuf;
- X char *fileName, c;
- X
- X if (argc < 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " option name ?arg ...?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X c = argv[1][0];
- X length = strlen(argv[1]);
- X
- X /*
- X * First handle operations on the file name.
- X */
- X
- X fileName = Tcl_TildeSubst(interp, argv[2]);
- X if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "dirname";
- X not3Args:
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " ", argv[1], " name\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X p = strrchr(fileName, '/');
- X if (p == NULL) {
- X interp->result = ".";
- X } else if (p == fileName) {
- X interp->result = "/";
- X } else {
- X *p = 0;
- X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
- X *p = '/';
- X }
- X return TCL_OK;
- X } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
- X && (length >= 2)) {
- X char *lastSlash;
- X
- X if (argc != 3) {
- X argv[1] = "rootname";
- X goto not3Args;
- X }
- X p = strrchr(fileName, '.');
- X lastSlash = strrchr(fileName, '/');
- X if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
- X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
- X } else {
- X *p = 0;
- X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
- X *p = '.';
- X }
- X return TCL_OK;
- X } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
- X && (length >= 3)) {
- X char *lastSlash;
- X
- X if (argc != 3) {
- X argv[1] = "extension";
- X goto not3Args;
- X }
- X p = strrchr(fileName, '.');
- X lastSlash = strrchr(fileName, '/');
- X if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
- X Tcl_SetResult(interp, p, TCL_VOLATILE);
- X }
- X return TCL_OK;
- X } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "tail";
- X goto not3Args;
- X }
- X p = strrchr(fileName, '/');
- X if (p != NULL) {
- X Tcl_SetResult(interp, p+1, TCL_VOLATILE);
- X } else {
- X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
- X }
- X return TCL_OK;
- X }
- X
- X /*
- X * Next, handle operations that can be satisfied with the "access"
- X * kernel call.
- X */
- X
- X if (fileName == NULL) {
- X return TCL_ERROR;
- X }
- X if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
- X && (length >= 2)) {
- X if (argc != 3) {
- X argv[1] = "readable";
- X goto not3Args;
- X }
- X mode = R_OK;
- X checkAccess:
- X if (access(fileName, mode) == -1) {
- X interp->result = "0";
- X } else {
- X interp->result = "1";
- X }
- X return TCL_OK;
- X } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "writable";
- X goto not3Args;
- X }
- X mode = W_OK;
- X goto checkAccess;
- X } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
- X && (length >= 3)) {
- X if (argc != 3) {
- X argv[1] = "executable";
- X goto not3Args;
- X }
- X mode = X_OK;
- X goto checkAccess;
- X } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
- X && (length >= 3)) {
- X if (argc != 3) {
- X argv[1] = "exists";
- X goto not3Args;
- X }
- X mode = F_OK;
- X goto checkAccess;
- X }
- X
- X /*
- X * Lastly, check stuff that requires the file to be stat-ed.
- X */
- X
- X if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "atime";
- X goto not3Args;
- X }
- X if (stat(fileName, &statBuf) == -1) {
- X goto badStat;
- X }
- X sprintf(interp->result, "%ld", statBuf.st_atime);
- X return TCL_OK;
- X } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
- X && (length >= 3)) {
- X if (argc != 3) {
- X argv[1] = "isdirectory";
- X goto not3Args;
- X }
- X statOp = 2;
- X } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
- X && (length >= 3)) {
- X if (argc != 3) {
- X argv[1] = "isfile";
- X goto not3Args;
- X }
- X statOp = 1;
- X } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "mtime";
- X goto not3Args;
- X }
- X if (stat(fileName, &statBuf) == -1) {
- X goto badStat;
- X }
- X sprintf(interp->result, "%ld", statBuf.st_mtime);
- X return TCL_OK;
- X } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
- X if (argc != 3) {
- X argv[1] = "owned";
- X goto not3Args;
- X }
- X statOp = 0;
- X } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
- X && (length >= 2)) {
- X if (argc != 3) {
- X argv[1] = "size";
- X goto not3Args;
- X }
- X if (stat(fileName, &statBuf) == -1) {
- X goto badStat;
- X }
- X sprintf(interp->result, "%ld", statBuf.st_size);
- X return TCL_OK;
- X } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
- X && (length >= 2)) {
- X char string[30];
- X
- X if (argc != 4) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " stat name varName\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X if (stat(fileName, &statBuf) == -1) {
- X badStat:
- X Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X return TCL_ERROR;
- X }
- X sprintf(string, "%d", statBuf.st_dev);
- X if (Tcl_SetVar2(interp, argv[3], "dev", string, 0) == NULL) {
- X setError:
- X Tcl_AppendResult(interp,
- X "couldn't store stat information in variable \"",
- X argv[3], "\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X sprintf(string, "%d", statBuf.st_ino);
- X if (Tcl_SetVar2(interp, argv[3], "ino", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%d", statBuf.st_mode);
- X if (Tcl_SetVar2(interp, argv[3], "mode", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%d", statBuf.st_nlink);
- X if (Tcl_SetVar2(interp, argv[3], "nlink", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%d", statBuf.st_uid);
- X if (Tcl_SetVar2(interp, argv[3], "uid", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%d", statBuf.st_gid);
- X if (Tcl_SetVar2(interp, argv[3], "gid", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%ld", statBuf.st_size);
- X if (Tcl_SetVar2(interp, argv[3], "size", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%ld", statBuf.st_atime);
- X if (Tcl_SetVar2(interp, argv[3], "atime", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%ld", statBuf.st_mtime);
- X if (Tcl_SetVar2(interp, argv[3], "mtime", string, 0) == NULL) {
- X goto setError;
- X }
- X sprintf(string, "%ld", statBuf.st_ctime);
- X if (Tcl_SetVar2(interp, argv[3], "ctime", string, 0) == NULL) {
- X goto setError;
- X }
- X return TCL_OK;
- X } else {
- X Tcl_AppendResult(interp, "bad option \"", argv[1],
- X "\": should be atime, dirname, executable, exists, ",
- X "extension, isdirectory, isfile, mtime, owned, ",
- X "readable, root, size, stat, tail, or writable",
- X (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (stat(fileName, &statBuf) == -1) {
- X interp->result = "0";
- X return TCL_OK;
- X }
- X switch (statOp) {
- X case 0:
- X mode = (geteuid() == statBuf.st_uid);
- X break;
- X case 1:
- X mode = (statBuf.st_mode & S_IFMT) == S_IFREG;
- X break;
- X case 2:
- X mode = (statBuf.st_mode & S_IFMT) == S_IFDIR;
- X break;
- X }
- X if (mode) {
- X interp->result = "1";
- X } else {
- X interp->result = "0";
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_FlushCmd --
- X *
- X * This procedure is invoked to process the "flush" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_FlushCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X FILE *f;
- X
- X if (argc != 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (!filePtr->writable) {
- X Tcl_AppendResult(interp, "\"", argv[1],
- X "\" wasn't opened for writing", (char *) NULL);
- X return TCL_ERROR;
- X }
- X f = filePtr->f2;
- X if (f == NULL) {
- X f = filePtr->f;
- X }
- X if (fflush(f) == EOF) {
- X Tcl_AppendResult(interp, "error flushing \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X clearerr(f);
- X return TCL_ERROR;
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_GetsCmd --
- X *
- X * This procedure is invoked to process the "gets" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_GetsCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X# define BUF_SIZE 200
- X char buffer[BUF_SIZE+1];
- X int totalCount, done, flags;
- X OpenFile *filePtr;
- X register FILE *f;
- X
- X if ((argc != 2) && (argc != 3)) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId ?varName?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (!filePtr->readable) {
- X Tcl_AppendResult(interp, "\"", argv[1],
- X "\" wasn't opened for reading", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X /*
- X * We can't predict how large a line will be, so read it in
- X * pieces, appending to the current result or to a variable.
- X */
- X
- X totalCount = 0;
- X done = 0;
- X flags = 0;
- X f = filePtr->f;
- X while (!done) {
- X register int c, count;
- X register char *p;
- X
- X for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
- X c = getc(f);
- X if (c == EOF) {
- X if (ferror(filePtr->f)) {
- X Tcl_ResetResult(interp);
- X Tcl_AppendResult(interp, "error reading \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X clearerr(filePtr->f);
- X return TCL_ERROR;
- X } else if (feof(filePtr->f)) {
- X if ((totalCount == 0) && (count == 0)) {
- X totalCount = -1;
- X }
- X done = 1;
- X break;
- X }
- X }
- X if (c == '\n') {
- X done = 1;
- X break;
- X }
- X *p = c;
- X }
- X *p = 0;
- X if (argc == 2) {
- X Tcl_AppendResult(interp, buffer, (char *) NULL);
- X } else {
- X Tcl_SetVar(interp, argv[2], buffer, flags);
- X flags = TCL_APPEND_VALUE;
- X }
- X totalCount += count;
- X }
- X
- X if (argc == 3) {
- X sprintf(interp->result, "%d", totalCount);
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_OpenCmd --
- X *
- X * This procedure is invoked to process the "open" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_OpenCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X Interp *iPtr = (Interp *) interp;
- X int pipeline, fd;
- X char *access;
- X register OpenFile *filePtr;
- X
- X if (argc == 2) {
- X access = "r";
- X } else if (argc == 3) {
- X access = argv[2];
- X } else {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " filename ?access?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
- X filePtr->f = NULL;
- X filePtr->f2 = NULL;
- X filePtr->readable = 0;
- X filePtr->writable = 0;
- X filePtr->numPids = 0;
- X filePtr->pidPtr = NULL;
- X filePtr->errorId = -1;
- X
- X /*
- X * Verify the requested form of access.
- X */
- X
- X pipeline = 0;
- X if (argv[1][0] == '|') {
- X pipeline = 1;
- X }
- X switch (access[0]) {
- X case 'r':
- X filePtr->readable = 1;
- X break;
- X case 'w':
- X filePtr->writable = 1;
- X break;
- X case 'a':
- X filePtr->writable = 1;
- X break;
- X default:
- X badAccess:
- X Tcl_AppendResult(interp, "illegal access mode \"", access,
- X "\"", (char *) NULL);
- X goto error;
- X }
- X if (access[1] == '+') {
- X filePtr->readable = filePtr->writable = 1;
- X if (access[2] != 0) {
- X goto badAccess;
- X }
- X } else if (access[1] != 0) {
- X goto badAccess;
- X }
- X
- X /*
- X * Open the file or create a process pipeline.
- X */
- X
- X if (!pipeline) {
- X char *fileName = argv[1];
- X
- X if (fileName[0] == '~') {
- X fileName = Tcl_TildeSubst(interp, fileName);
- X if (fileName == NULL) {
- X goto error;
- X }
- X }
- X filePtr->f = fopen(fileName, access);
- X if (filePtr->f == NULL) {
- X Tcl_AppendResult(interp, "couldn't open \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X goto error;
- X }
- X } else {
- X int *inPipePtr, *outPipePtr;
- X int cmdArgc, inPipe, outPipe;
- X char **cmdArgv;
- X
- X if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
- X goto error;
- X }
- X inPipePtr = (filePtr->writable) ? &inPipe : NULL;
- X outPipePtr = (filePtr->readable) ? &outPipe : NULL;
- X inPipe = outPipe = -1;
- X filePtr->numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
- X &filePtr->pidPtr, inPipePtr, outPipePtr, &filePtr->errorId);
- X ckfree((char *) cmdArgv);
- X if (filePtr->numPids < 0) {
- X goto error;
- X }
- X if (filePtr->readable) {
- X if (outPipe == -1) {
- X if (inPipe != -1) {
- X close(inPipe);
- X }
- X Tcl_AppendResult(interp, "can't read output from command:",
- X " standard output was redirected", (char *) NULL);
- X goto error;
- X }
- X filePtr->f = fdopen(outPipe, "r");
- X }
- X if (filePtr->writable) {
- X if (inPipe == -1) {
- X Tcl_AppendResult(interp, "can't write input to command:",
- X " standard input was redirected", (char *) NULL);
- X goto error;
- X }
- X if (filePtr->f != NULL) {
- X filePtr->f2 = fdopen(inPipe, "w");
- X } else {
- X filePtr->f = fdopen(inPipe, "w");
- X }
- X }
- X }
- X
- X /*
- X * Enter this new OpenFile structure in the table for the
- X * interpreter. May have to expand the table to do this.
- X */
- X
- X fd = fileno(filePtr->f);
- X TclMakeFileTable(iPtr, fd);
- X if (iPtr->filePtrArray[fd] != NULL) {
- X panic("Tcl_OpenCmd found file already open");
- X }
- X iPtr->filePtrArray[fd] = filePtr;
- X sprintf(interp->result, "file%d", fd);
- X return TCL_OK;
- X
- X error:
- X if (filePtr->f != NULL) {
- X fclose(filePtr->f);
- X }
- X if (filePtr->f2 != NULL) {
- X fclose(filePtr->f2);
- X }
- X if (filePtr->numPids > 0) {
- X Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
- X ckfree((char *) filePtr->pidPtr);
- X }
- X if (filePtr->errorId != -1) {
- X close(filePtr->errorId);
- X }
- X ckfree((char *) filePtr);
- X return TCL_ERROR;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_PwdCmd --
- X *
- X * This procedure is invoked to process the "pwd" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_PwdCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X char buffer[MAXPATHLEN+1];
- X
- X if (argc != 1) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"",
- X argv[0], "\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (currentDir == NULL) {
- X#if TCL_GETWD
- X if (getwd(buffer) == NULL) {
- X Tcl_AppendResult(interp, "error getting working directory name: ",
- X buffer, (char *) NULL);
- X return TCL_ERROR;
- X }
- X#else
- X if (getcwd(buffer, MAXPATHLEN) == NULL) {
- X if (errno == ERANGE) {
- X interp->result = "working directory name is too long";
- X } else {
- X Tcl_AppendResult(interp,
- X "error getting working directory name: ",
- X Tcl_UnixError(interp), (char *) NULL);
- X }
- X return TCL_ERROR;
- X }
- X#endif
- X currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
- X strcpy(currentDir, buffer);
- X }
- X interp->result = currentDir;
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_PutsCmd --
- X *
- X * This procedure is invoked to process the "puts" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_PutsCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X FILE *f;
- X
- X if (argc == 4) {
- X if (strncmp(argv[3], "nonewline", strlen(argv[3])) != 0) {
- X Tcl_AppendResult(interp, "bad argument \"", argv[3],
- X "\": should be \"nonewline\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X } else if (argc != 3) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId string ?nonewline?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (!filePtr->writable) {
- X Tcl_AppendResult(interp, "\"", argv[1],
- X "\" wasn't opened for writing", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X f = filePtr->f2;
- X if (f == NULL) {
- X f = filePtr->f;
- X }
- X fputs(argv[2], f);
- X if (argc == 3) {
- X fputc('\n', f);
- X }
- X if (ferror(f)) {
- X Tcl_AppendResult(interp, "error writing \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X clearerr(f);
- X return TCL_ERROR;
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_ReadCmd --
- X *
- X * This procedure is invoked to process the "read" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_ReadCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X int numBytes, count;
- X struct stat statBuf;
- X int newline;
- X
- X if ((argc != 2) && (argc != 3)) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId ?numBytes|nonewline?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (!filePtr->readable) {
- X Tcl_AppendResult(interp, "\"", argv[1],
- X "\" wasn't opened for reading", (char *) NULL);
- X return TCL_ERROR;
- X }
- X
- X /*
- X * Compute how many bytes to read, and see whether the final
- X * newline should be dropped.
- X */
- X
- X newline = 1;
- X if ((argc > 2) && isdigit(argv[2][0])) {
- X if (Tcl_GetInt(interp, argv[2], &numBytes) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X } else {
- X
- X /*
- X * Compute how many bytes are left in the file. Try to read
- X * one more byte than this, just to force the eof condition
- X * to be seen.
- X */
- X
- X if (fstat(fileno(filePtr->f), &statBuf) < 0) {
- X Tcl_AppendResult(interp,
- X "couldn't compute size of \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X return TCL_ERROR;
- X }
- X numBytes = statBuf.st_size - ftell(filePtr->f) + 1;
- X if (argc > 2) {
- X if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
- X newline = 0;
- X } else {
- X Tcl_AppendResult(interp, "bad argument \"", argv[2],
- X "\": should be \"nonewline\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X }
- X }
- X
- X /*
- X * Read the bytes into a dynamically-allocated array, and
- X * return it as result.
- X */
- X
- X interp->result = (char *) ckalloc((unsigned) numBytes+1);
- X interp->freeProc = (Tcl_FreeProc *) free;
- X count = fread(interp->result, 1, numBytes, filePtr->f);
- X if (ferror(filePtr->f)) {
- X Tcl_ResetResult(interp);
- X Tcl_AppendResult(interp, "error reading \"", argv[1],
- X "\": ", Tcl_UnixError(interp), (char *) NULL);
- X clearerr(filePtr->f);
- X return TCL_ERROR;
- X }
- X if ((newline == 0) && (interp->result[count-1] == '\n')) {
- X interp->result[count-1] = 0;
- X } else {
- X interp->result[count] = 0;
- X }
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_SeekCmd --
- X *
- X * This procedure is invoked to process the "seek" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_SeekCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X int offset, mode;
- X
- X if ((argc != 3) && (argc != 4)) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId offset ?origin?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X mode = SEEK_SET;
- X if (argc == 4) {
- X int length;
- X char c;
- X
- X length = strlen(argv[3]);
- X c = argv[3][0];
- X if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
- X mode = SEEK_SET;
- X } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
- X mode = SEEK_CUR;
- X } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
- X mode = SEEK_END;
- X } else {
- X Tcl_AppendResult(interp, "bad origin \"", argv[3],
- X "\": should be start, current, or end", (char *) NULL);
- X return TCL_ERROR;
- X }
- X }
- X if (fseek(filePtr->f, offset, mode) == -1) {
- X Tcl_AppendResult(interp, "error during seek: ",
- X Tcl_UnixError(interp), (char *) NULL);
- X clearerr(filePtr->f);
- X return TCL_ERROR;
- X }
- X
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_SourceCmd --
- X *
- X * This procedure is invoked to process the "source" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_SourceCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X if (argc != 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileName\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X return Tcl_EvalFile(interp, argv[1]);
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_TellCmd --
- X *
- X * This procedure is invoked to process the "tell" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_TellCmd(notUsed, interp, argc, argv)
- X ClientData notUsed; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X OpenFile *filePtr;
- X
- X if (argc != 2) {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " fileId\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X sprintf(interp->result, "%d", ftell(filePtr->f));
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * Tcl_TimeCmd --
- X *
- X * This procedure is invoked to process the "time" Tcl command.
- X * See the user documentation for details on what it does.
- X *
- X * Results:
- X * A standard Tcl result.
- X *
- X * Side effects:
- X * See the user documentation.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- X /* ARGSUSED */
- Xint
- XTcl_TimeCmd(dummy, interp, argc, argv)
- X ClientData dummy; /* Not used. */
- X Tcl_Interp *interp; /* Current interpreter. */
- X int argc; /* Number of arguments. */
- X char **argv; /* Argument strings. */
- X{
- X int count, i, result;
- X double timePer;
- X#if TCL_GETTOD
- X struct timeval start, stop;
- X struct timezone tz;
- X int micros;
- X#else
- X struct tms dummy2;
- X long start, stop;
- X long ticks;
- X#endif
- X
- X if (argc == 2) {
- X count = 1;
- X } else if (argc == 3) {
- X if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- X return TCL_ERROR;
- X }
- X } else {
- X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- X " command ?count?\"", (char *) NULL);
- X return TCL_ERROR;
- X }
- X#if TCL_GETTOD
- X gettimeofday(&start, &tz);
- X#else
- X start = times(&dummy2);
- X#endif
- X for (i = count ; i > 0; i--) {
- X result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
- X if (result != TCL_OK) {
- X if (result == TCL_ERROR) {
- X char msg[60];
- X sprintf(msg, "\n (\"time\" body line %d)",
- X interp->errorLine);
- X Tcl_AddErrorInfo(interp, msg);
- X }
- X return result;
- X }
- X }
- X#if TCL_GETTOD
- X gettimeofday(&stop, &tz);
- X micros = (stop.tv_sec - start.tv_sec)*1000000
- X + (stop.tv_usec - start.tv_usec);
- X timePer = micros;
- X#else
- X stop = times(&dummy2);
- X timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
- X#endif
- X Tcl_ResetResult(interp);
- X sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
- X return TCL_OK;
- X}
- X
- X/*
- X *----------------------------------------------------------------------
- X *
- X * CleanupChildren --
- X *
- X * This is a utility procedure used to wait for child processes
- X * to exit, record information about abnormal exits, and then
- X * collect any stderr output generated by them.
- X *
- X * Results:
- X * The return value is a standard Tcl result. If anything at
- X * weird happened with the child processes, TCL_ERROR is returned
- X * and a message is left in interp->result.
- X *
- X * Side effects:
- X * If the last character of interp->result is a newline, then it
- X * is removed. File errorId gets closed, and pidPtr is freed
- X * back to the storage allocator.
- X *
- X *----------------------------------------------------------------------
- X */
- X
- Xstatic int
- XCleanupChildren(interp, numPids, pidPtr, errorId)
- X Tcl_Interp *interp; /* Used for error messages. */
- X int numPids; /* Number of entries in pidPtr array. */
- X int *pidPtr; /* Array of process ids of children. */
- X int errorId; /* File descriptor index for file containing
- X * stderr output from pipeline. -1 means
- X * there isn't any stderr output. */
- X{
- X int result = TCL_OK;
- X int i, pid, length;
- X WAIT_STATUS_TYPE waitStatus;
- X
- X for (i = 0; i < numPids; i++) {
- X pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);
- X if (pid == -1) {
- X Tcl_AppendResult(interp, "error waiting for process to exit: ",
- X Tcl_UnixError(interp), (char *) NULL);
- X continue;
- X }
- X
- X /*
- X * Create error messages for unusual process exits. An
- X * extra newline gets appended to each error message, but
- X * it gets removed below (in the same fashion that an
- X * extra newline in the command's output is removed).
- X */
- X
- X if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
- X char msg1[20], msg2[20];
- X
- X result = TCL_ERROR;
- X sprintf(msg1, "%d", pid);
- X if (WIFEXITED(waitStatus)) {
- X sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
- X Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
- X (char *) NULL);
- X } else if (WIFSIGNALED(waitStatus)) {
- X char *p;
- X
- X p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
- X Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
- X Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
- X (char *) NULL);
- X Tcl_AppendResult(interp, "child killed: ", p, "\n",
- X (char *) NULL);
- X } else if (WIFSTOPPED(waitStatus)) {
- X char *p;
- X
- X p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
- X Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
- X Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
- X Tcl_AppendResult(interp, "child suspended: ", p, "\n",
- X (char *) NULL);
- X } else {
- X Tcl_AppendResult(interp,
- X "child wait status didn't make sense\n",
- X (char *) NULL);
- X }
- X }
- X }
- X ckfree((char *) pidPtr);
- X
- X /*
- X * Read the standard error file. If there's anything there,
- X * then return an error and add the file's contents to the result
- X * string.
- X */
- X
- X if (errorId >= 0) {
- X while (1) {
- X# define BUFFER_SIZE 1000
- X char buffer[BUFFER_SIZE+1];
- X int count;
- X
- X count = read(errorId, buffer, BUFFER_SIZE);
- X
- X if (count == 0) {
- X break;
- X }
- X if (count < 0) {
- X Tcl_AppendResult(interp,
- X "error reading stderr output file: ",
- X Tcl_UnixError(interp), (char *) NULL);
- X break;
- X }
- X buffer[count] = 0;
- X Tcl_AppendResult(interp, buffer, (char *) NULL);
- X }
- X close(errorId);
- X }
- X
- X /*
- X * If the last character of interp->result is a newline, then remove
- X * the newline character (the newline would just confuse things).
- X */
- X
- X length = strlen(interp->result);
- X if ((length > 0) && (interp->result[length-1] == '\n')) {
- X interp->result[length-1] = '\0';
- X }
- X
- X return result;
- X}
- END_OF_FILE
- if test 39407 -ne `wc -c <'tcl6.1/tclUnixAZ.c'`; then
- echo shar: \"'tcl6.1/tclUnixAZ.c'\" unpacked with wrong size!
- fi
- # end of 'tcl6.1/tclUnixAZ.c'
- fi
- echo shar: End of archive 30 \(of 33\).
- cp /dev/null ark30isdone
- MISSING=""
- for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
- if test ! -f ark${I}isdone ; then
- MISSING="${MISSING} ${I}"
- fi
- done
- if test "${MISSING}" = "" ; then
- echo You have unpacked all 33 archives.
- rm -f ark[1-9]isdone ark[1-9][0-9]isdone
- else
- echo You still need to unpack the following archives:
- echo " " ${MISSING}
- fi
- ## End of shell archive.
- exit 0
-
- exit 0 # Just in case...
- --
- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
- Sterling Software, IMD UUCP: uunet!sparky!kent
- Phone: (402) 291-8300 FAX: (402) 291-4362
- Please send comp.sources.misc-related mail to kent@uunet.uu.net.
-