tclecosaz.c

CMX990 demonstration board (DE9901)

	    && (length >= 5)) {
	char linkValue[MAXPATHLEN+1];
	int linkLength;

	if (argc != 3) {
	    argv[1] = "readlink";
	    goto not3Args;
	}
	linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
	if (linkLength == -1) {
	    Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
		    "\": ", Tcl_UnixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	linkValue[linkLength] = 0;
	Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
	return TCL_OK;
#endif
    } 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);
	return TCL_OK;
    } 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);
	    return TCL_ERROR;
	}

	if (stat(fileName, &statBuf) == -1) {
	    badStat:
	    Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
		    "\": ", Tcl_UnixError(interp), (char *) NULL);
	    return TCL_ERROR;
	}
	return StoreStatData(interp, argv[3], &statBuf);
    } 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);
	return TCL_OK;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be atime, dirname, executable, exists, ",
		"extension, isdirectory, isfile, lstat, mtime, owned, ",
		"readable, ",
#ifdef S_IFLNK
		"readlink, ",
#endif
		"root, size, stat, tail, type, ",
		"or writable",
		(char *) NULL);
	return TCL_ERROR;
    }
    if (stat(fileName, &statBuf) == -1) {
	interp->result = "0";
	return TCL_OK;
    }
    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";
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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", (long)statPtr->st_atime);
    if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
	    == NULL) {
	return TCL_ERROR;
    }
    sprintf(string, "%ld", (long)statPtr->st_mtime);
    if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
	    == NULL) {
	return TCL_ERROR;
    }
    sprintf(string, "%ld", (long)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. */
{
    OpenFile *filePtr;
    FILE *f;

    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;
    }
    if (!filePtr->writable) {
	Tcl_AppendResult(interp, "\"", argv[1],
		"\" wasn't opened for writing", (char *) NULL);
	return TCL_ERROR;
    }
    f = filePtr->f2;
    if (f == NULL) {
	f = filePtr->f;
    }
    if (fflush(f) == EOF) {
	Tcl_AppendResult(interp, "error flushing \"", argv[1],
		"\": ", Tcl_UnixError(interp), (char *) NULL);
	clearerr(f);
	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;
    OpenFile *filePtr;
    register FILE *f;

    if ((argc != 2) && (argc != 3)) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" fileId ?varName?\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
	return TCL_ERROR;
    }
    if (!filePtr->readable) {
	Tcl_AppendResult(interp, "\"", argv[1],
		"\" wasn't opened for reading", (char *) NULL);
	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;
    f = filePtr->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(filePtr->f)) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "error reading \"", argv[1],
			    "\": ", Tcl_UnixError(interp), (char *) NULL);
		    clearerr(filePtr->f);
		    return TCL_ERROR;
		} else if (feof(filePtr->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. */
{
    Interp *iPtr = (Interp *) interp;
    int pipeline, fd;
    char *access;
    register OpenFile *filePtr;

    if (argc == 2) {
	access = "r";
    } else if (argc == 3) {
	access = argv[2];
    } else {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" filename ?access?\"", (char *) NULL);
	return TCL_ERROR;
    }

    filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
    filePtr->f = NULL;
    filePtr->f2 = NULL;
    filePtr->readable = 0;
    filePtr->writable = 0;
    filePtr->numPids = 0;
    filePtr->pidPtr = NULL;
    filePtr->errorId = -1;

    /*
     * Verify the requested form of access.
     */

    pipeline = 0;
#if TCL_FORK_ENABLED
    if (argv[1][0] == '|') {
	pipeline = 1;
    }
#endif
    switch (access[0]) {
	case 'r':
	    filePtr->readable = 1;
	    break;
	case 'w':
	    filePtr->writable = 1;
	    break;
	case 'a':
	    filePtr->writable = 1;
	    break;
	default:
	    badAccess:
	    Tcl_AppendResult(interp, "illegal access mode \"", access,
		    "\"", (char *) NULL);
	    goto error;
    }
    if (access[1] == '+') {
	filePtr->readable = filePtr->writable = 1;
	if (access[2] != 0) {
	    goto badAccess;
	}
    } else if (access[1] != 0) {
	goto badAccess;
    }

    /*
     * Open the file or create a process pipeline.
     */

    if (!pipeline) {
	char *fileName = argv[1];

	if (fileName[0] == '~') {
	    fileName = Tcl_TildeSubst(interp, fileName);
	    if (fileName == NULL) {
		goto error;
	    }
	}
	filePtr->f = fopen(fileName, access);
	if (filePtr->f == NULL) {
	    Tcl_AppendResult(interp, "couldn't open \"", argv[1],
		    "\": ", Tcl_UnixError(interp), (char *) NULL);
	    goto error;
	}
    } else {
#if TCL_FORK_ENABLED
	int *inPipePtr, *outPipePtr;
	int cmdArgc, inPipe, outPipe;
	char **cmdArgv;

	if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
	    goto error;
	}
	inPipePtr = (filePtr->writable) ? &inPipe : NULL;
	outPipePtr = (filePtr->readable) ? &outPipe : NULL;
	inPipe = outPipe = -1;
	filePtr->numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
		&filePtr->pidPtr, inPipePtr, outPipePtr, &filePtr->errorId);
	ckfree((char *) cmdArgv);
	if (filePtr->numPids < 0) {
	    goto error;
	}
	if (filePtr->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 error;
	    }
	    filePtr->f = fdopen(outPipe, "r");
	}
	if (filePtr->writable) {
	    if (inPipe == -1) {
		Tcl_AppendResult(interp, "can't write input to command:",
			" standard input was redirected", (char *) NULL);
		goto error;
	    }
	    if (filePtr->f != NULL) {
		filePtr->f2 = fdopen(inPipe, "w");
	    } else {
		filePtr->f = fdopen(inPipe, "w");
	    }
	}
#endif
    }

    /*
     * Enter this new OpenFile structure in the table for the
     * interpreter.  May have to expand the table to do this.
     */

    fd = fileno(filePtr->f);
    TclMakeFileTable(iPtr, fd);
    if (iPtr->filePtrArray[fd] != NULL) {
	panic("Tcl_OpenCmd found file already open");
    }
    iPtr->filePtrArray[fd] = filePtr;
    sprintf(interp->result, "file%d", fd);
    return TCL_OK;

    error:
    if (filePtr->f != NULL) {
	fclose(filePtr->f);
    }
    if (filePtr->f2 != NULL) {
	fclose(filePtr->f2);
    }
#if TCL_FORK_ENABLED
    if (filePtr->numPids > 0) {
	Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
	ckfree((char *) filePtr->pidPtr);
    }
#endif
    if (filePtr->errorId != -1) {
	close(filePtr->errorId);
    }
    ckfree((char *) filePtr);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * 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 \"",