tclecosaz.c

CMX990 demonstration board (DE9901)

		argv[0], "\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (currentDir == NULL) {
#if TCL_GETWD
	if (getwd(buffer) == NULL) {
	    Tcl_AppendResult(interp, "error getting working directory name: ",
		    buffer, (char *) NULL);
	    return TCL_ERROR;
	}
#else
	if (getcwd(buffer, MAXPATHLEN) == NULL) {
	    if (errno == ERANGE) {
		interp->result = "working directory name is too long";
	    } else {
		Tcl_AppendResult(interp,
			"error getting working directory name: ",
			Tcl_UnixError(interp), (char *) NULL);
	    }
	    return TCL_ERROR;
	}
#endif
	currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
	strcpy(currentDir, buffer);
    }
    interp->result = currentDir;
    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. */
{
    OpenFile *filePtr;
    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 (TclGetOpenFile(interp, fileId, &filePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!filePtr->writable) {
	Tcl_AppendResult(interp, "\"", fileId,
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }
    f = filePtr->f2;
    if (f == NULL) {
	f = filePtr->f;
    }

    fputs(argv[i], f);
    if (newline) {
	fputc('\n', f);
    }
    if (ferror(f)) {
	Tcl_AppendResult(interp, "error writing \"", fileId,
		"\": ", Tcl_UnixError(interp), (char *) NULL);
	clearerr(f);
	return TCL_ERROR;
    }
    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. */
{
    OpenFile *filePtr;
    int bytesLeft, bytesRead, count;
#define READ_BUF_SIZE 4096
    char buffer[READ_BUF_SIZE+1];
    int newline, i;

    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 (TclGetOpenFile(interp, argv[i], &filePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!filePtr->readable) {
	Tcl_AppendResult(interp, "\"", argv[i],
		"\" wasn't opened for reading", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Compute how many bytes to read, and see whether the final
     * newline should be dropped.
     */

    if ((argc >= (i + 2)) && isdigit(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;
    while (bytesLeft > 0) {
	count = READ_BUF_SIZE;
	if (bytesLeft < READ_BUF_SIZE) {
	    count = bytesLeft;
	}
	count = fread(buffer, 1, count, filePtr->f);
	if (ferror(filePtr->f)) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp, "error reading \"", argv[i],
		    "\": ", Tcl_UnixError(interp), (char *) NULL);
	    clearerr(filePtr->f);
	    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. */
{
    OpenFile *filePtr;
    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 (TclGetOpenFile(interp, argv[1], &filePtr) != 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;
	}
    }
    if (fseek(filePtr->f, (long) offset, mode) == -1) {
	Tcl_AppendResult(interp, "error during seek: ",
		Tcl_UnixError(interp), (char *) NULL);
	clearerr(filePtr->f);
	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. */
{
    OpenFile *filePtr;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" fileId\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    sprintf(interp->result, "%ld", ftell(filePtr->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.
 *
 *----------------------------------------------------------------------
 */
#if 0
	/* 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 TCL_GETTOD
    struct timeval start, stop;
    struct timezone tz;
    int micros;
#else
    struct tms dummy2;
    long start, stop;
#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 TCL_GETTOD
    gettimeofday(&start, &tz);
#else
    start = times(&dummy2);
#endif
    for (i = count ; i > 0; i--) {
	result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
	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 TCL_GETTOD
    gettimeofday(&stop, &tz);
    micros = (stop.tv_sec - start.tv_sec)*1000000
	    + (stop.tv_usec - start.tv_usec);
    timePer = micros;
#else
    stop = times(&dummy2);
    timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
#endif
    Tcl_ResetResult(interp);
    sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
    return TCL_OK;
}
#endif

/*
 *----------------------------------------------------------------------
 *
 * 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.  File errorId gets closed, and pidPtr is freed
 *	back to the storage allocator.
 *
 *----------------------------------------------------------------------
 */
#if TCL_FORK_ENABLED
static int
CleanupChildren(interp, numPids, pidPtr, errorId)
    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 result = TCL_OK;
    int i, pid, length;
#define WAIT_STATUS_TYPE int
    WAIT_STATUS_TYPE waitStatus;

    for (i = 0; i < numPids; i++) {
	pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);
	if (pid == -1) {
	    Tcl_AppendResult(interp, "error waiting for process to exit: ",
		    Tcl_UnixError(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);
	    } 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, BUFFER_SIZE);
    
	    if (count == 0) {
		break;
	    }
	    if (count < 0) {
		Tcl_AppendResult(interp,
			"error reading stderr output file: ",
			Tcl_UnixError(interp), (char *) NULL);
		break;
	    }
	    buffer[count] = 0;
	    Tcl_AppendResult(interp, buffer, (char *) NULL);
	}
	close(errorId);
    }

    /*
     * If the last character of interp->result is a newline, then remove
     * the newline character (the newline would just confuse things).
     */

    length = strlen(interp->result);
    if ((length > 0) && (interp->result[length-1] == '\n')) {
	interp->result[length-1] = '\0';
    }

    return result;
}
#endif