From: peter@ficc.uu.net (Peter da Silva)
Newsgroups: alt.sources
Subject: TCL for System V (part 04/06)
Summary: Tool Command Language for System V and Xenix/286.
Message-ID: <OD224WBxds13@ficc.uu.net>
Date: 7 Mar 90 11:27:20 GMT
Sender: peter@ficc.uu.net (Peter da Silva)
Organization: Xenix Support, FICC
Lines: 1343
Posted: Wed Mar  7 12:27:20 1990


Archive-name: tcl/Part04

#! /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 4 (of 6)."
# Contents:  tclCmdAH.c
# Wrapped by peter@ficc.uu.net on Wed Mar  7 05:16:09 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tclCmdAH.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tclCmdAH.c'\"
else
echo shar: Extracting \"'tclCmdAH.c'\" \(31115 characters\)
sed "s/^X//" >'tclCmdAH.c' <<'END_OF_FILE'
X/* 
X * tclCmdAH.c --
X *
X *	This file contains the top-level command routines for most of
X *	the Tcl built-in commands whose names begin with the letters
X *	A to H.
X *
X * Copyright 1987 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 the above copyright
X * notice appear 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: /sprite/src/lib/tcl/RCS/tclCmdAH.c,v 1.38 90/01/15 15:15:48 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <ctype.h>
X#include <errno.h>
X#include <signal.h>
X#include <stdio.h>
X#include <stdlib.h>
X#include <string.h>
X#include <sys/types.h>
X#include <sys/file.h>
X#include <sys/stat.h>
X#include <time.h>
X
X#ifdef BSD
X# include <sys/resource.h>
X# include <sys/wait.h>
X# include <sys/errno.h>
Xtypedef union wait WAIT;
X#else
X# include <fcntl.h>
X# ifdef M_XENIX
X#  define F_OK 00
X#  define X_OK 01
X#  define W_OK 02
X#  define R_OK 04
X# else
X#  include <unistd.h>
X# endif
Xextern int errno;
X#define WAIT int
X#define SIGCHLD SIGCLD
X#endif
X
X#include "tclInt.h"
X
X#define TMPFILENAME "/tmp/tcl.XXXXXX"
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_BreakCmd --
X *
X *	This procedure is invoked to process the "break" 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_BreakCmd(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 != 1) {
X	sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
X	return TCL_ERROR;
X    }
X    return TCL_BREAK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CaseCmd --
X *
X *	This procedure is invoked to process the "case" 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_CaseCmd(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 i, result;
X    int body;
X    char *string;
X
X    if (argc < 4) {
X	sprintf(interp->result,
X		"%s \"%.50s string [in] patList body ... [default body]\"",
X		"not enough args:  should be", argv[0]);
X	return TCL_ERROR;
X    }
X    string = argv[1];
X    body = NULL;
X    if (strcmp(argv[2], "in") == 0) {
X	i = 3;
X    } else {
X	i = 2;
X    }
X    for (; i < argc; i += 2) {
X	int patArgc, j;
X	char **patArgv;
X	register char *p;
X
X	if (i == (argc-1)) {
X	    sprintf(interp->result, "extra pattern with no body in \"%.50s\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X
X	/*
X	 * Check for special case of single pattern (no list) with
X	 * no backslash sequences.
X	 */
X
X	for (p = argv[i]; *p != 0; p++) {
X	    if (isspace(*p) || (*p == '\\')) {
X		break;
X	    }
X	}
X	if (*p == 0) {
X	    if ((*argv[i] == 'd') && (strcmp(argv[i], "default") == 0)) {
X		body = i+1;
X	    }
X	    if (Tcl_StringMatch(string, argv[i])) {
X		body = i+1;
X		goto match;
X	    }
X	    continue;
X	}
X
X	/*
X	 * Break up pattern lists, then check each of the patterns
X	 * in the list.
X	 */
X
X	result = Tcl_SplitList(interp, argv[i], &patArgc, &patArgv);
X	if (result != TCL_OK) {
X	    return result;
X	}
X	for (j = 0; j < patArgc; j++) {
X	    if (Tcl_StringMatch(string, patArgv[j])) {
X		body = i+1;
X		break;
X	    }
X	}
X	ckfree((char *) patArgv);
X	if (j < patArgc) {
X	    break;
X	}
X    }
X
X    match:
X    if (body != NULL) {
X	result = Tcl_Eval(interp, argv[body], 0, (char **) NULL);
X	if (result == TCL_ERROR) {
X	    char msg[100];
X	    sprintf(msg, " (\"%.50s\" arm line %d)", argv[i],
X		    interp->errorLine);
X	    Tcl_AddErrorInfo(interp, msg);
X	}
X	return result;
X    }
X
X    /*
X     * Nothing matched:  return nothing.
X     */
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CatchCmd --
X *
X *	This procedure is invoked to process the "catch" 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_CatchCmd(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 result;
X
X    if ((argc != 2) && (argc != 3)) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s command [varName]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    if (argc == 3) {
X	Tcl_SetVar(interp, argv[2], interp->result, 0);
X    }
X    Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X    sprintf(interp->result, "%d", result);
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ConcatCmd --
X *
X *	This procedure is invoked to process the "concat" 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_ConcatCmd(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 == 1) {
X	return TCL_OK;
X    }
X
X    interp->result = Tcl_Concat(argc-1, argv+1);
X    interp->dynamic = 1;
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ContinueCmd --
X *
X *	This procedure is invoked to process the "continue" 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_ContinueCmd(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 != 1) {
X	sprintf(interp->result, "too many args: should be \"%.50s\"", argv[0]);
X	return TCL_ERROR;
X    }
X    return TCL_CONTINUE;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ErrorCmd --
X *
X *	This procedure is invoked to process the "error" 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_ErrorCmd(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	sprintf(interp->result, "wrong # args: should be \"%.50s message\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    Tcl_Return(interp, argv[1], TCL_VOLATILE);
X    return TCL_ERROR;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_EvalCmd --
X *
X *	This procedure is invoked to process the "eval" 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_EvalCmd(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 result;
X    char *cmd;
X
X    if (argc < 2) {
X	return TCL_OK;
X    }
X    if (argc == 2) {
X	result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    } else {
X    
X	/*
X	 * More than one argument:  concatenate them together with spaces
X	 * between, then evaluate the result.
X	 */
X    
X	cmd = Tcl_Concat(argc-1, argv+1);
X	result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X	ckfree(cmd);
X    }
X    if (result == TCL_ERROR) {
X	char msg[60];
X	sprintf(msg, " (\"eval\" body line %d)", interp->errorLine);
X	Tcl_AddErrorInfo(interp, msg);
X    }
X    return result;
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    char *input = NULL;			/* Standard input for child. */
X    char *output = NULL;		/* Output received from child. */
X    int outputSize;			/* Number of valid bytes at output. */
X    int outputSpace;			/* Total space available at output. */
X    int stdIn, stdOut[2], count, result, i, deadPid, maxID;
X    int pid = -1;			/* -1 means child process doesn't
X					 * exist (yet).  Non-zero gives its
X					 * id. 0 only in child. */
X    WAIT status;
X    char *cmdName;
X
X    /*
X     * Look through the arguments for a standard input specification
X     * ("< value" in two arguments).  If found, collapse it out.
X     * Shuffle all the arguments back over the "exec" argument, so that
X     * there's room for a NULL argument at the end.
X     */
X
X    cmdName = argv[0];
X    for (i = 1; i < argc; i++) {
X	argv[i-1] = argv[i];
X	if ((argv[i][0] != '<') || (argv[i][1] != 0)) {
X	    continue;
X	}
X	i++;
X	if (i >= argc) {
X	    sprintf(interp->result,
X		    "specified \"<\" but no input in \"%.50s\" command",
X		    cmdName);
X	    return TCL_ERROR;
X	}
X	input = argv[i];
X	for (i++; i < argc; i++) {
X	    argv[i-3] = argv[i];
X	}
X	argc -= 2;
X    }
X
X    argc -= 1;			/* Drop "exec" argument. */
X    argv[argc] = NULL;
X    if (argc < 1) {
X	sprintf(interp->result, "not enough arguments to \"%.50s\" command",
X		cmdName);
X	return TCL_ERROR;
X    }
X
X    /*
X     * Create pipes for standard standard output/error, and
X     * start up the new process.
X     */
X
X    stdIn = -1;
X    stdOut[0] = stdOut[1] = -1;
X    if (pipe(stdOut) < 0) {
X	sprintf(interp->result, "couldn't create pipe for \"%.50s\" command",
X		cmdName);
X	result = TCL_ERROR;
X	goto cleanup;
X    }
X
X    /*
X     * To avoid hassles, I'm creating a temp file for the input string,
X     * automatically deleted (invsible). I hope /tmp isn't a network
X     * mount :->.
X     */
X    if(input) {
X	static char tmp[sizeof TMPFILENAME];
X	strcpy(tmp, TMPFILENAME);
X	mktemp(tmp);
X	if((stdIn = open(tmp, O_RDWR|O_CREAT, 0)) == -1) {
X		sprintf(interp->result,
X			"couldn't make temp file for \"%.50s\" command: %.50s",
X			cmdName, strerror(errno));
X		result = TCL_ERROR;
X		goto cleanup;
X	}
X	write(stdIn, input, strlen(input));
X	lseek(stdIn, 0L, 0);
X	unlink(tmp);
X    }
X
X    pid = fork();
X    if (pid == -1) {
X	sprintf(interp->result,
X		"couldn't fork child for \"%.50s\" command: %.50s",
X		cmdName, strerror(errno));
X	result = TCL_ERROR;
X	goto cleanup;
X    }
X    if (pid == 0) {
X	char errSpace[100];
X
X	if (( (stdIn != -1) && (dup2(stdIn, 0) == -1) )
X	   || (dup2(stdOut[1], 1) == -1) || (dup2(stdOut[1], 2) == -1)) {
X	    char *err;
X	    err = "forked process couldn't set up input/output";
X	    write(stdOut[1], err, strlen(err));
X	    _exit(1);
X	}
X	if(stdIn != -1)
X	    close(stdIn);
X	close(stdOut[0]);
X	close(stdOut[1]);
X	execvp(argv[0], argv);
X	sprintf(errSpace, "couldn't find a \"%.50s\" to execute", argv[0]);
X	write(1, errSpace, strlen(errSpace));
X	_exit(1);
X    }
X
X    if(stdIn != -1)
X	close(stdIn);
X    stdIn = -1;
X    close(stdOut[1]);
X    stdOut[1] = -1;
X    /*
X     * In the parent, arrange to be signalled when the child dies, then
X     * funnel input and output to/from the process.
X     */
X
X    outputSize = 0;
X    outputSpace = 0;
X
X    result = -1;
X    while (1) {
X	if ((outputSpace - outputSize) < 100) {
X	    char *newOutput;
X    
X	    if (outputSpace == 0) {
X	        outputSpace = 200;
X	    } else {
X	        outputSpace = 2*outputSpace;
X	    }
X	    newOutput = (char *) ckalloc((unsigned) outputSpace);
X	    if (output != 0) {
X	        bcopy(output, newOutput, outputSize);
X	        ckfree(output);
X	    }
X	    output = newOutput;
X	}
X
X	count = read(stdOut[0], output+outputSize,
X	    outputSpace-outputSize-1);
X
X	if (count == 0)
X	    break;
X	if (count < 0) {
X	    sprintf(interp->result,
X		"error reading stdout during \"%.50s\": %.50s",
X		cmdName, strerror(errno));
X	    result = TCL_ERROR;
X	    goto cleanup;
X	} else {
X	    outputSize += count;
X	}
X    }
X    output[outputSize] = 0;
X    interp->result = output;
X    interp->dynamic = 1;
X
Xcleanup:
X    if(pid != -1) {
X        while(wait(&status) != pid)
X		fprintf(stderr, "Whoa!\n");
X	if(status&0xFF)
X		result = -1;
X	else
X		result = (status&0xFF) >> 8;
X    }
X    if (stdIn != -1) {
X	close(stdIn);
X    }
X    if (stdOut[0] != -1) {
X	close(stdOut[0]);
X    }
X    if (stdOut[1] != -1) {
X	close(stdOut[1]);
X    }
X    return result;
X}
X
X/*
X * Variable for communication between Tcl_ShellCmd and ShellHandlerProc:
X * non-zero means a signal has arrived.
X */
X
Xint execSignalled;
X
X/*
X * Procedure to receive signals during "exec" command:  just return.
X */
X
Xvoid
XExecHandlerProc()
X{
X    execSignalled = 1;
X    return;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ExprCmd --
X *
X *	This procedure is invoked to process the "expr" 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_ExprCmd(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 result, value;
X
X    if (argc != 2) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s expression\"", argv[0]);
X	return TCL_ERROR;
X    }
X
X    result = Tcl_Expr(interp, argv[1], &value);
X    if (result != TCL_OK) {
X	return result;
X    }
X
X    /*
X     * Turn the integer result back into a string.
X     */
X
X    sprintf(interp->result, "%d", value);
X    return TCL_OK;
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, mode, statOp;
X    struct stat statBuf;
X
X    if (argc != 3) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s name option\"", argv[0]);
X	return TCL_ERROR;
X    }
X    length = strlen(argv[2]);
X
X    /*
X     * First handle operations on the file name.
X     */
X
X    if ((argv[2][0] == 'd') && (strncmp(argv[2], "dirname", length) == 0)) {
X	p = strrchr(argv[1], '/');
X	if (p == NULL) {
X	    interp->result = ".";
X	} else if (p == argv[1]) {
X	    interp->result = "/";
X	} else {
X	    *p = 0;
X	    Tcl_Return(interp, argv[1], TCL_VOLATILE);
X	    *p = '/';
X	}
X	return TCL_OK;
X    } else if ((argv[2][0] == 'r') && (length >= 2)
X	    && (strncmp(argv[2], "rootname", length) == 0)) {
X	p = strrchr(argv[1], '.');
X	if (p == NULL) {
X	    Tcl_Return(interp, argv[1], TCL_VOLATILE);
X	} else {
X	    *p = 0;
X	    Tcl_Return(interp, argv[1], TCL_VOLATILE);
X	    *p = '.';
X	}
X	return TCL_OK;
X    } else if ((argv[2][0] == 'e') && (length >= 3)
X	    && (strncmp(argv[2], "extension", length) == 0)) {
X	p = strrchr(argv[1], '.');
X	if (p != NULL) {
X	    Tcl_Return(interp, p, TCL_VOLATILE);
X	}
X	return TCL_OK;
X    } else if ((argv[2][0] == 't') && (strncmp(argv[2], "tail", length) == 0)) {
X	p = strrchr(argv[1], '/');
X	if (p != NULL) {
X	    Tcl_Return(interp, p+1, TCL_VOLATILE);
X	} else {
X	    Tcl_Return(interp, argv[1], 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 ((argv[2][0] == 'r') && (length >= 2)
X	    && (strncmp(argv[2], "readable", length) == 0)) {
X	mode = R_OK;
X	checkAccess:
X	if (access(argv[1], mode) == -1) {
X	    interp->result = "0";
X	} else {
X	    interp->result = "1";
X	}
X	return TCL_OK;
X    } else if ((argv[2][0] == 'w')
X	    && (strncmp(argv[2], "writable", length) == 0)) {
X	mode = W_OK;
X	goto checkAccess;
X    } else if ((argv[2][0] == 'e') && (length >= 3)
X	    && (strncmp(argv[2], "executable", length) == 0)) {
X	mode = X_OK;
X	goto checkAccess;
X    } else if ((argv[2][0] == 'e') && (length >= 3)
X	    && (strncmp(argv[2], "exists", length) == 0)) {
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 ((argv[2][0] == 'o') && (strncmp(argv[2], "owned", length) == 0)) {
X	statOp = 0;
X    } else if ((argv[2][0] == 'i') && (length >= 3)
X	    && (strncmp(argv[2], "isfile", length) == 0)) {
X	statOp = 1;
X    } else if ((argv[2][0] == 'i') && (length >= 3)
X	    && (strncmp(argv[2], "isdirectory", length) == 0)) {
X	statOp = 2;
X    } else {
X	sprintf(interp->result, "bad \"%.30s\" option \"%.30s\": must be dirname, executable, exists, extension, isdirectory, isfile, owned, readable, root, tail, or writable",
X		argv[0], argv[2]);
X	return TCL_ERROR;
X    }
X    if (stat(argv[1], &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_ForCmd --
X *
X *	This procedure is invoked to process the "for" 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_ForCmd(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 result, value;
X
X    if (argc != 5) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s start test next command\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X
X    result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X    if (result != TCL_OK) {
X	if (result == TCL_ERROR) {
X	    Tcl_AddErrorInfo(interp, " (\"for\" initial command)");
X	}
X	return result;
X    }
X    while (1) {
X	result = Tcl_Expr(interp, argv[2], &value);
X	if (result != TCL_OK) {
X	    return result;
X	}
X	if (!value) {
X	    break;
X	}
X	result = Tcl_Eval(interp, argv[4], 0, (char **) NULL);
X	if (result == TCL_CONTINUE) {
X	    result = TCL_OK;
X	} else if (result != TCL_OK) {
X	    if (result == TCL_ERROR) {
X		char msg[60];
X		sprintf(msg, " (\"for\" body line %d)", interp->errorLine);
X		Tcl_AddErrorInfo(interp, msg);
X	    }
X	    break;
X	}
X	result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
X	if (result == TCL_BREAK) {
X	    break;
X	} else if (result != TCL_OK) {
X	    if (result == TCL_ERROR) {
X		Tcl_AddErrorInfo(interp, " (\"for\" loop-end command)");
X	    }
X	    return result;
X	}
X    }
X    if (result == TCL_BREAK) {
X	result = TCL_OK;
X    }
X    if (result == TCL_OK) {
X	Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X    }
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ForeachCmd --
X *
X *	This procedure is invoked to process the "foreach" 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_ForeachCmd(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 listArgc, i, result;
X    char **listArgv;
X
X    if (argc != 4) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s varName list command\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X
X    /*
X     * Break the list up into elements, and execute the command once
X     * for each value of the element.
X     */
X
X    result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
X    if (result != TCL_OK) {
X	return result;
X    }
X    for (i = 0; i < listArgc; i++) {
X	Tcl_SetVar(interp, argv[1], listArgv[i], 0);
X
X	result = Tcl_Eval(interp, argv[3], 0, (char **) NULL);
X	if (result != TCL_OK) {
X	    if (result == TCL_CONTINUE) {
X		result = TCL_OK;
X	    } else if (result == TCL_BREAK) {
X		result = TCL_OK;
X		break;
X	    } else if (result == TCL_ERROR) {
X		char msg[100];
X		sprintf(msg, " (\"foreach\" body line %d)", interp->errorLine);
X		Tcl_AddErrorInfo(interp, msg);
X		break;
X	    } else {
X		break;
X	    }
X	}
X    }
X    ckfree((char *) listArgv);
X    if (result == TCL_OK) {
X	Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X    }
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_FormatCmd --
X *
X *	This procedure is invoked to process the "format" 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_FormatCmd(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    register char *format;	/* Used to read characters from the format
X				 * string. */
X    char newFormat[40];		/* A new format specifier is generated here. */
X    int width;			/* Field width from field specifier, or 0 if
X				 * no width given. */
X    int precision;		/* Field precision from field specifier, or 0
X				 * if no precision given. */
X    int size;			/* Number of bytes needed for result of
X				 * conversion, based on type of conversion
X				 * ("e", "s", etc.) and width from above. */
X    char *oneWordValue;		/* Used to hold value to pass to sprintf, if
X				 * it's a one-word value. */
X    double twoWordValue;	/* Used to hold value to pass to sprintf if
X				 * it's a two-word value. */
X    int useTwoWords;		/* 0 means use oneWordValue, 1 means use
X				 * twoWordValue. */
X    char *dst = interp->result;	/* Where result is stored.  Starts off at
X				 * interp->resultSpace, but may get dynamically
X				 * re-allocated if this isn't enough. */
X    int dstSize = 0;		/* Number of non-null characters currently
X				 * stored at dst. */
X    int dstSpace = TCL_RESULT_SIZE;
X				/* Total amount of storage space available
X				 * in dst (not including null terminator. */
X    int noPercent;		/* Special case for speed:  indicates there's
X				 * no field specifier, just a string to copy. */
X    char **curArg;		/* Remainder of argv array. */
X
X    /*
X     * This procedure is a bit nasty.  The goal is to use sprintf to
X     * do most of the dirty work.  There are several problems:
X     * 1. this procedure can't trust its arguments.
X     * 2. we must be able to provide a large enough result area to hold
X     *    whatever's generated.  This is hard to estimate.
X     * 2. there's no way to move the arguments from argv to the call
X     *    to sprintf in a reasonable way.  This is particularly nasty
X     *    because some of the arguments may be two-word values (doubles).
X     * So, what happens here is to scan the format string one % group
X     * at a time, making many individual calls to sprintf.
X     */
X
X    if (argc < 2) {
X	sprintf(interp->result,
X		"too few args: should be \"%.50s formatString arg arg ...\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    curArg = argv+2;
X    argc -= 2;
X    for (format = argv[1]; *format != 0; ) {
X	register char *newPtr = newFormat;
X
X	width = precision = useTwoWords = noPercent = 0;
X
X	/*
X	 * Get rid of any characters before the next field specifier.
X	 * Collapse backslash sequences found along the way.
X	 */
X
X	if (*format != '%') {
X	    register char *p;
X	    int bsSize;
X
X	    oneWordValue = format;
X	    for (p = format; (*format != '%') && (*format != 0); p++) {
X		if (*format == '\\') {
X		    *p = Tcl_Backslash(format, &bsSize);
X		    format += bsSize;
X		} else {
X		    *p = *format;
X		    format++;
X		}
X	    }
X	    size = p - oneWordValue;
X	    noPercent = 1;
X	    goto doField;
X	}
X
X	if (format[1] == '%') {
X	    oneWordValue = format;
X	    size = 1;
X	    noPercent = 1;
X	    format += 2;
X	    goto doField;
X	}
X
X	/*
X	 * Parse off a field specifier, compute how many characters
X	 * will be needed to store the result, and substitute for
X	 * "*" size specifiers.
X	 */
X
X	*newPtr = '%';
X	newPtr++;
X	format++;
X	if (*format == '-') {
X	    *newPtr = '-';
X	    newPtr++;
X	    format++;
X	}
X	if (*format == '0') {
X	    *newPtr = '0';
X	    newPtr++;
X	    format++;
X	}
X	if (isdigit(*format)) {
X	    width = atoi(format);
X	    do {
X		format++;
X	    } while (isdigit(*format));
X	} else if (*format == '*') {
X	    if (argc <= 0) {
X		goto notEnoughArgs;
X	    }
X	    width = atoi(*curArg);
X	    argc--;
X	    curArg++;
X	    format++;
X	}
X	if (width != 0) {
X	    sprintf(newPtr, "%d", width);
X	    while (*newPtr != 0) {
X		newPtr++;
X	    }
X	}
X	if (*format == '.') {
X	    *newPtr = '.';
X	    newPtr++;
X	    format++;
X	}
X	if (isdigit(*format)) {
X	    precision = atoi(format);
X	    do {
X		format++;
X	    } while (isdigit(*format));
X	} else if (*format == '*') {
X	    if (argc <= 0) {
X		goto notEnoughArgs;
X	    }
X	    precision = atoi(*curArg);
X	    argc--;
X	    curArg++;
X	    format++;
X	}
X	if (precision != 0) {
X	    sprintf(newPtr, "%d", precision);
X	    while (*newPtr != 0) {
X		newPtr++;
X	    }
X	}
X	if (*format == '#') {
X	    *newPtr = '#';
X	    newPtr++;
X	    format++;
X	}
X	if (*format == 'l') {
X	    format++;
X	}
X	*newPtr = *format;
X	newPtr++;
X	*newPtr = 0;
X	if (argc <= 0) {
X	    goto notEnoughArgs;
X	}
X	switch (*format) {
X	    case 'D':
X	    case 'd':
X	    case 'O':
X	    case 'o':
X	    case 'X':
X	    case 'x':
X	    case 'U':
X	    case 'u': {
X		char *end;
X
X		oneWordValue = (char *) strtol(*curArg, &end, 0);
X		if ((*curArg == 0) || (*end != 0)) {
X		    sprintf(interp->result,
X			    "expected integer but got \"%.50s\" instead",
X			    *curArg);
X		    goto fmtError;
X		}
X		size = 40;
X		break;
X	    }
X	    case 's':
X		oneWordValue = *curArg;
X		size = strlen(*curArg);
X		break;
X	    case 'c': {
X		char *end;
X
X		oneWordValue = (char *) strtol(*curArg, &end, 0);
X		if ((*curArg == 0) || (*end != 0)) {
X		    sprintf(interp->result,
X			    "expected integer but got \"%.50s\" instead",
X			    *curArg);
X		    goto fmtError;
X		}
X		size = 1;
X		break;
X	    }
X	    case 'F':
X	    case 'f':
X	    case 'E':
X	    case 'e':
X	    case 'G':
X	    case 'g':
X		if (sscanf(*curArg, "%F", &twoWordValue) != 1) {
X		    sprintf(interp->result,
X			    "expected floating-point number but got \"%.50s\" instead",
X			    *curArg);
X		    goto fmtError;
X		}
X		useTwoWords = 1;
X		size = 320;
X		if (precision > 10) {
X		    size += precision;
X		}
X		break;
X	    case 0:
X		interp->result = "format string ended in middle of field specifier";
X		goto fmtError;
X	    default:
X		sprintf(interp->result, "bad field specifier \"%c\"", *format);
X		goto fmtError;
X	}
X	argc--;
X	curArg++;
X	format++;
X
X	/*
X	 * Make sure that there's enough space to hold the formatted
X	 * result, then format it.
X	 */
X
X	doField:
X	if (width > size) {
X	    size = width;
X	}
X	if ((dstSize + size) > dstSpace) {
X	    char *newDst;
X	    int newSpace;
X
X	    newSpace = 2*(dstSize + size);
X	    newDst = (char *) ckalloc((unsigned) newSpace+1);
X	    if (dstSize != 0) {
X		bcopy(dst, newDst, dstSize);
X	    }
X	    if (dstSpace != TCL_RESULT_SIZE) {
X		ckfree(dst);
X	    }
X	    dst = newDst;
X	    dstSpace = newSpace;
X	}
X	if (noPercent) {
X	    bcopy(oneWordValue, dst+dstSize, size);
X	    dstSize += size;
X	    dst[dstSize] = 0;
X	} else {
X	    if (useTwoWords) {
X		sprintf(dst+dstSize, newFormat, twoWordValue);
X	    } else {
X		sprintf(dst+dstSize, newFormat, oneWordValue);
X	    }
X	    dstSize += strlen(dst+dstSize);
X	}
X    }
X
X    interp->result = dst;
X    interp->dynamic = !(dstSpace == TCL_RESULT_SIZE);
X    return TCL_OK;
X
X    notEnoughArgs:
X    sprintf(interp->result,
X	    "invoked \"%.50s\" without enough arguments", argv[0]);
X    fmtError:
X    if (dstSpace != TCL_RESULT_SIZE) {
X	ckfree(dst);
X    }
X    return TCL_ERROR;
X}
X 
X#ifdef GNU
X/*
X * ----------------------------------------------------------------------------
X *
X * Tcl_GlobCmd --
X *
X *      Expands a pattern in a directory using csh rules.
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_GlobCmd(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 == 1) {
X	return TCL_OK;
X    }
X
X    return Tcl_Glob(interp, argc, argv);
X}
X#endif
END_OF_FILE
if test 31115 -ne `wc -c <'tclCmdAH.c'`; then
    echo shar: \"'tclCmdAH.c'\" unpacked with wrong size!
fi
# end of 'tclCmdAH.c'
fi
echo shar: End of archive 4 \(of 6\).
cp /dev/null ark4isdone
MISSING=""
for I in 1 2 3 4 5 6 ; do
    if test ! -f ark${I}isdone ; then
	MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 6 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
-- 
 _--_|\  `-_-' Peter da Silva. +1 713 274 5180. <peter@ficc.uu.net>.
/      \  'U`
\_.--._/ "I've about decided that the net is not the place to do the right
      v   thing. It might violate a charter somewhere ..." -- Spenser Aden


