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


Archive-name: tcl/Part05

#! /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 5 (of 6)."
# Contents:  tclCmdIZ.c
# Wrapped by peter@ficc.uu.net on Wed Mar  7 05:16:11 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tclCmdIZ.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tclCmdIZ.c'\"
else
echo shar: Extracting \"'tclCmdIZ.c'\" \(32065 characters\)
sed "s/^X//" >'tclCmdIZ.c' <<'END_OF_FILE'
X/* 
X * tclCmdIZ.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 *	I to Z.
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/tclCmdIZ.c,v 1.30 90/01/31 09:21:58 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <ctype.h>
X#include <errno.h>
X#include <stdio.h>
X#include <stdlib.h>
X#include <string.h>
X#ifdef M_XENIX
X# include <sys/param.h>
X#else
X# include <sys/types.h>
X#endif
X#include <sys/file.h>
X#include <sys/stat.h>
X#ifdef BSD
X# include <sys/time.h>
X#else
Xextern int errno;
X# ifndef M_XENIX
X#  include <sys/param.h>
X# endif
X# include <sys/times.h>
X# include <fcntl.h>
X#endif
X#include "tclInt.h"
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_IfCmd --
X *
X *	This procedure is invoked to process the "if" 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_IfCmd(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 *condition, *ifPart, *elsePart, *cmd, *name;
X    int result, value;
X
X    name = argv[0];
X    if (argc < 3) {
X	ifSyntax:
X	sprintf(interp->result, "wrong # args:  should be \"%.50s bool [then] command [[else] command]\"",
X		name);
X	return TCL_ERROR;
X    }
X    condition = argv[1];
X    argc -= 2;
X    argv += 2;
X    if ((**argv == 't') && (strncmp(*argv, "then", strlen(*argv)) == 0)) {
X	argc--;
X	argv++;
X    }
X    if (argc < 1) {
X	goto ifSyntax;
X    }
X    ifPart = *argv;
X    argv++;
X    argc--;
X    if (argc == 0) {
X	elsePart = "";
X    } else {
X	if ((**argv == 'e') && (strncmp(*argv, "else", strlen(*argv)) == 0)) {
X	    argc--;
X	    argv++;
X	}
X	if (argc != 1) {
X	    goto ifSyntax;
X	}
X	elsePart = *argv;
X    }
X
X    cmd = ifPart;
X    result = Tcl_Expr(interp, condition, &value);
X    if (result != TCL_OK) {
X	return result;
X    }
X    if (value == 0) {
X	cmd = elsePart;
X    }
X    result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    if (result == TCL_ERROR) {
X	char msg[60];
X	sprintf(msg, " (\"if\" body line %d)", interp->errorLine);
X	Tcl_AddErrorInfo(interp, msg);
X    }
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_IndexCmd --
X *
X *	This procedure is invoked to process the "strchr" 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_IndexCmd(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, *element;
X    int strchr, size, parenthesized, result;
X
X    if (argc < 3) {
X	strchrSyntax:
X	sprintf(interp->result,
X		"wrong # args:  should be \"%.50s value strchr [chars]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    p = argv[1];
X    strchr = atoi(argv[2]);
X    if (!isdigit(*argv[2]) || (strchr < 0)) {
X	badIndex:
X	sprintf(interp->result, "bad strchr \"%.50s\"", argv[2]);
X	return TCL_ERROR;
X    }
X    if (argc == 3) {
X	for ( ; strchr >= 0; strchr--) {
X	    result = TclFindElement(interp, p, &element, &p, &size,
X		    &parenthesized);
X	    if (result != TCL_OK) {
X		return result;
X	    }
X	}
X	if (size >= TCL_RESULT_SIZE) {
X	    interp->result = (char *) ckalloc((unsigned) size+1);
X	    interp->dynamic = 1;
X	}
X	if (parenthesized) {
X	    bcopy(element, interp->result, size);
X	    interp->result[size] = 0;
X	} else {
X	    TclCopyAndCollapse(size, element, interp->result);
X	}
X    } else if ((argc == 4)
X	    && (strncmp(argv[3], "chars", strlen(argv[3])) == 0)) {
X	size = strlen(p);
X	if (strchr >= size) {
X	    goto badIndex;
X	}
X	interp->result[0] = p[strchr];
X	interp->result[1] = 0;
X    } else {
X	goto strchrSyntax;
X    }
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_InfoCmd --
X *
X *	This procedure is invoked to process the "info" 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_InfoCmd(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 Interp *iPtr = (Interp *) interp;
X    Proc *procPtr;
X    Var *varPtr;
X    Command *cmdPtr;
X    int length;
X    char c;
X
X    /*
X     * When collecting a list of things (e.g. args or vars) "flag" tells
X     * what kind of thing is being collected, according to the definitions
X     * below.
X     */
X
X    int flag;
X#   define VARS 0
X#   define LOCALS 1
X#   define PROCS 2
X#   define CMDS 3
X
X#   define ARG_SIZE 20
X    char *argSpace[ARG_SIZE];
X    int argSize;
X    char *pattern;
X
X    if (argc < 2) {
X	sprintf(iPtr->result,
X		"too few args:  should be \"%.50s option [arg arg ...]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    c = argv[1][0];
X    length = strlen(argv[1]);
X    if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
X	if (argc != 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s args procname\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	procPtr = TclFindProc(iPtr, argv[2]);
X	if (procPtr == NULL) {
X	    infoNoSuchProc:
X	    sprintf(iPtr->result,
X		    "info requested on \"%s\", which isn't a procedure",
X		    argv[2]);
X	    return TCL_ERROR;
X	}
X	flag = VARS;
X	varPtr = procPtr->argPtr;
X	argc = 0;			/* Prevent pattern matching. */
X    } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
X	if (argc != 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s body procname\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	procPtr = TclFindProc(iPtr, argv[2]);
X	if (procPtr == NULL) {
X	    goto infoNoSuchProc;
X	}
X	iPtr->result = procPtr->command;
X	return TCL_OK;
X    } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
X	    && (length >= 2)) {
X	if (argc != 2) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s cmdcount\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	sprintf(iPtr->result, "%d", iPtr->cmdCount);
X	return TCL_OK;
X    } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
X	    && (length >= 2)){
X	if (argc > 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s commands [pattern]\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	flag = CMDS;
X	cmdPtr = iPtr->commandPtr;
X    } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
X	if (argc != 5) {
X	    sprintf(iPtr->result, "wrong # args: should be \"%.50s default procname arg varname\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	procPtr = TclFindProc(iPtr, argv[2]);
X	if (procPtr == NULL) {
X	    goto infoNoSuchProc;
X	}
X	for (varPtr = procPtr->argPtr; ; varPtr = varPtr->nextPtr) {
X	    if (varPtr == NULL) {
X		sprintf(iPtr->result,
X			"procedure \"%s\" doesn't have an argument \"%s\"",
X			argv[2], argv[3]);
X		return TCL_ERROR;
X	    }
X	    if (strcmp(argv[3], varPtr->name) == 0) {
X		if (varPtr->value != NULL) {
X		    Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], varPtr->value, 0);
X		    iPtr->result = "1";
X		} else {
X		    Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0);
X		    iPtr->result = "0";
X		}
X		return TCL_OK;
X	    }
X	}
X    } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
X	if (argc > 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s globals [pattern]\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	flag = VARS;
X	varPtr = iPtr->globalPtr;
X    } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
X	     && (length >= 2)) {
X	if (argc > 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s locals [pattern]\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	flag = LOCALS;
X	if (iPtr->varFramePtr == NULL) {
X	    varPtr = NULL;
X	} else {
X	    varPtr = iPtr->varFramePtr->varPtr;
X	}
X    } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
X	    && (length >= 2)) {
X	if (argc == 2) {
X	    if (iPtr->varFramePtr == NULL) {
X		iPtr->result = "0";
X	    } else {
X		sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
X	    }
X	    return TCL_OK;
X	} else if (argc == 3) {
X	    int level;
X	    char *end;
X	    CallFrame *framePtr;
X
X	    level = strtol(argv[2], &end, 10);
X	    if ((end == argv[2]) || (*end != '\0')) {
X		levelError:
X		sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]);
X		return TCL_ERROR;
X	    }
X	    if (level <= 0) {
X		if (iPtr->varFramePtr == NULL) {
X		    goto levelError;
X		}
X		level += iPtr->varFramePtr->level;
X	    }
X	    if (level == 0) {
X		return TCL_OK;
X	    }
X	    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
X		    framePtr = framePtr->callerVarPtr) {
X		if (framePtr->level == level) {
X		    break;
X		}
X	    }
X	    if (framePtr == NULL) {
X		goto levelError;
X	    }
X	    iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
X	    iPtr->dynamic = 1;
X	    return TCL_OK;
X	}
X	sprintf(iPtr->result,
X		"wrong # args: should be \"%.50s level [number]\"",
X		argv[0]);
X	return TCL_ERROR;
X    } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
X	if (argc > 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s procs [pattern]\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	flag = PROCS;
X	cmdPtr = iPtr->commandPtr;
X    } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
X
X	/*
X	 * Note:  TCL_VERSION below is expected to be set with a "-D"
X	 * switch in the Makefile.
X	 */
X
X	strcpy(iPtr->result, TCL_VERSION);
X	return TCL_OK;
X    } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
X	if (argc > 3) {
X	    sprintf(iPtr->result,
X		    "wrong # args: should be \"%.50s vars [pattern]\"",
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	flag = VARS;
X	if (iPtr->varFramePtr == NULL) {
X	    varPtr = iPtr->globalPtr;
X	} else {
X	    varPtr = iPtr->varFramePtr->varPtr;
X	}
X    } else {
X	sprintf(iPtr->result, "bad \"%.50s\" option \"%.50s\": must be args, body, commands, cmdcount, default, globals, level, locals, procs, tclversion, or vars",
X		argv[0], argv[1]);
X	return TCL_ERROR;
X    }
X
X    /*
X     * At this point we have to assemble a list of something or other.
X     * Collect them in an expandable argv-argc array.
X     */
X
X    if (argc == 3) {
X	pattern = argv[2];
X    } else {
X	pattern = NULL;
X    }
X    argv = argSpace;
X    argSize = ARG_SIZE;
X    argc = 0;
X    while (1) {
X	/*
X	 * Increase the size of the argument array if necessary to
X	 * accommodate another string.
X	 */
X
X	if (argc == argSize) {
X	    char **newArgs;
X
X	    argSize *= 2;
X	    newArgs = (char **) ckalloc((unsigned) argSize*sizeof(char *));
X	    bcopy((char *) argv, (char *) newArgs, argc*sizeof(char *));
X	    if (argv != argSpace) {
X		ckfree((char *) argv);
X	    }
X	    argv = newArgs;
X	}
X
X	if ((flag == PROCS) || (flag == CMDS)) {
X	    if (flag == PROCS) {
X		for ( ; cmdPtr != NULL; cmdPtr = cmdPtr->nextPtr) {
X		    if (TclIsProc(cmdPtr)) {
X			break;
X		    }
X		}
X	    }
X	    if (cmdPtr == NULL) {
X		break;
X	    }
X	    argv[argc] = cmdPtr->name;
X	    cmdPtr = cmdPtr->nextPtr;
X	} else {
X	    if (flag == LOCALS) {
X		for ( ; varPtr != NULL; varPtr = varPtr->nextPtr) {
X		    if (!(varPtr->flags & VAR_GLOBAL)) {
X			break;
X		    }
X		}
X	    }
X	    if (varPtr == NULL) {
X		break;
X	    }
X	    argv[argc] = varPtr->name;
X	    varPtr = varPtr->nextPtr;
X	}
X	if ((pattern == NULL)  || Tcl_StringMatch(argv[argc], pattern)) {
X	    argc++;
X	}
X    }
X
X    iPtr->result = Tcl_Merge(argc, argv);
X    iPtr->dynamic = 1;
X    if (argv != argSpace) {
X	ckfree((char *) argv);
X    }
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LengthCmd --
X *
X *	This procedure is invoked to process the "length" 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_LengthCmd(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;
X    char *p;
X
X    if (argc < 2) {
X	lengthSyntax:
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s value [chars]\"", argv[0]);
X	return TCL_ERROR;
X    }
X    p = argv[1];
X    if (argc == 2) {
X	char *element;
X	int result;
X
X	for (count = 0; *p != 0 ; count++) {
X	    result = TclFindElement(interp, p, &element, &p, (int *) NULL,
X		    (int *) NULL);
X	    if (result != TCL_OK) {
X		return result;
X	    }
X	    if (*element == 0) {
X		break;
X	    }
X	}
X    } else if ((argc == 3)
X	    && (strncmp(argv[2], "chars", strlen(argv[2])) == 0)) {
X	count = strlen(p);
X    } else {
X	goto lengthSyntax;
X    }
X    sprintf(interp->result, "%d", count);
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ListCmd --
X *
X *	This procedure is invoked to process the "list" 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_ListCmd(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    interp->result = Tcl_Merge(argc-1, argv+1);
X    interp->dynamic = 1;
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_PrintCmd --
X *
X *	This procedure is invoked to process the "print" 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_PrintCmd(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    FILE *f;
X    int result;
X
X    if ((argc < 2) || (argc > 4)) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s string [file [append]]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X
X    if (argc == 2) {
X	f = stdout;
X    } else {
X	if (argc == 4) {
X	    if (strncmp(argv[3], "append", strlen(argv[3])) != 0) {
X		sprintf(interp->result,
X			"bad option \"%.50s\":  must be \"append\"",
X			argv[3]);
X		return TCL_ERROR;
X	    }
X	    f = fopen(argv[2], "a");
X	} else {
X	    f = fopen(argv[2], "w");
X	}
X	if (f == NULL) {
X	    sprintf(interp->result, "couldn't open \"%.50s\": %.80s",
X		    argv[2], strerror(errno));
X	    return TCL_ERROR;
X	}
X    }
X    fputs(argv[1], f);
X    if (argc == 2) {
X	result = fflush(stdout);
X    } else {
X	result = fclose(f);
X    }
X    if (result == EOF) {
X	sprintf(interp->result, "I/O error while writing: %.50s",
X		strerror(errno));
X	return TCL_ERROR;
X    }
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_RangeCmd --
X *
X *	This procedure is invoked to process the "range" 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_RangeCmd(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    int first, last, result;
X    char *begin, *end, c, *dummy;
X    int count;
X
X    if (argc < 4) {
X	rangeSyntax:
X	sprintf(interp->result, "wrong #/type of args: should be \"%.50s value first last [chars]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    first = atoi(argv[2]);
X    if (!isdigit(*argv[2]) || (first < 0)) {
X	sprintf(interp->result, "bad range specifier \"%.50s\"", argv[2]);
X	return TCL_ERROR;
X    }
X    if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
X	last = -1;
X    } else {
X	last = atoi(argv[3]);
X	if (!isdigit(*argv[3]) || (last < 0)) {
X	    sprintf(interp->result, "bad range specifier \"%.50s\"", argv[3]);
X	    return TCL_ERROR;
X	}
X    }
X
X    if (argc == 5) {
X	count = strlen(argv[4]);
X	if ((count == 0) || (strncmp(argv[4], "chars", count) != 0)) {
X	    goto rangeSyntax;
X	}
X
X	/*
X	 * Extract a range of characters.
X	 */
X
X	count = strlen(argv[1]);
X	if (first >= count) {
X	    interp->result = "";
X	    return TCL_OK;
X	}
X	begin = argv[1] + first;
X	if ((last == -1) || (last >= count)) {
X	    last = count;
X	} else if (last < first) {
X	    interp->result = "";
X	    return TCL_OK;
X	}
X	end = argv[1] + last + 1;
X    } else {
X	if (argc != 4) {
X	    goto rangeSyntax;
X	}
X
X	/*
X	 * Extract a range of fields.
X	 */
X
X	for (count = 0, begin = argv[1]; count < first; count++) {
X	    result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
X		    (int *) NULL);
X	    if (result != TCL_OK) {
X		return result;
X	    }
X	    if (*begin == 0) {
X		break;
X	    }
X	}
X	if (last == -1) {
X	    Tcl_Return(interp, begin, TCL_VOLATILE);
X	    return TCL_OK;
X	}
X	if (last < first) {
X	    interp->result = "";
X	    return TCL_OK;
X	}
X	for (count = first, end = begin; (count <= last) && (*end != 0);
X		count++) {
X	    result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
X		    (int *) NULL);
X	    if (result != TCL_OK) {
X		return result;
X	    }
X	}
X
X	/*
X	 * Chop off trailing spaces.
X	 */
X
X	while (isspace(end[-1])) {
X	    end--;
X	}
X    }
X    c = *end;
X    *end = 0;
X    Tcl_Return(interp, begin, TCL_VOLATILE);
X    *end = c;
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_RenameCmd --
X *
X *	This procedure is invoked to process the "rename" 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_RenameCmd(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 Command *oldPtr, *newPtr;
X    Interp *iPtr = (Interp *) interp;
X
X    if (argc != 3) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s oldName newName\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    if (argv[2][0] == '\0') {
X	Tcl_DeleteCommand(interp, argv[1]);
X	return TCL_OK;
X    }
X    newPtr = TclFindCmd(iPtr, argv[2], 0);
X    if (newPtr != NULL) {
X	sprintf(interp->result, "can't rename to \"%.50s\": already exists",
X		argv[2]);
X	return TCL_ERROR;
X    }
X    oldPtr = TclFindCmd(iPtr, argv[1], 0);
X    if (oldPtr == NULL) {
X	sprintf(interp->result,
X		"can't rename \"%.50s\":  command doesn't exist",
X		argv[1]);
X	return TCL_ERROR;
X    }
X    iPtr->commandPtr = oldPtr->nextPtr;
X    newPtr = (Command *) ckalloc(CMD_SIZE(strlen(argv[2])));
X    newPtr->proc = oldPtr->proc;
X    newPtr->clientData = oldPtr->clientData;
X    newPtr->deleteProc = oldPtr->deleteProc;
X    newPtr->nextPtr = iPtr->commandPtr;
X    iPtr->commandPtr = newPtr;
X    strcpy(newPtr->name, argv[2]);
X    ckfree((char *) oldPtr);
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ReturnCmd --
X *
X *	This procedure is invoked to process the "return" 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_ReturnCmd(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, "too many args: should be \"%.50s [value]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    if (argc == 2) {
X	Tcl_Return(interp, argv[1], TCL_VOLATILE);
X    }
X    return TCL_RETURN;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ScanCmd --
X *
X *	This procedure is invoked to process the "scan" 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_ScanCmd(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 arg1Length;			/* Number of bytes in argument to be
X					 * scanned.  This gives an upper limit
X					 * on string field sizes. */
X#   define MAX_FIELDS 20
X    typedef struct {
X	char fmt;			/* Format for field. */
X	int size;			/* How many bytes to allow for
X					 * field. */
X	char *location;			/* Where field will be stored. */
X    } Field;
X    Field fields[MAX_FIELDS];		/* Info about all the fields in the
X					 * format string. */
X    register Field *curField;
X    int numFields = 0;			/* Number of fields actually
X					 * specified. */
X    int suppress;			/* Current field is assignment-
X					 * suppressed. */
X    int totalSize = 0;			/* Number of bytes needed to store
X					 * all results combined. */
X    char *results;			/* Where scanned output goes.  */
X    int numScanned;			/* sscanf's result. */
X    register char *fmt;
X    int i;
X
X    if (argc < 3) {
X	sprintf(interp->result,
X		"too few args: should be \"%.50s string format varName ...\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X
X    /*
X     * This procedure operates in four stages:
X     * 1. Scan the format string, collecting information about each field.
X     * 2. Allocate an array to hold all of the scanned fields.
X     * 3. Call sscanf to do all the dirty work, and have it store the
X     *    parsed fields in the array.
X     * 4. Pick off the fields from the array and assign them to variables.
X     */
X
X    arg1Length = (strlen(argv[1]) + 4) & ~03;
X    for (fmt = argv[2]; *fmt != 0; fmt++) {
X	if (*fmt != '%') {
X	    continue;
X	}
X	fmt++;
X	if (*fmt == '*') {
X	    suppress = 1;
X	    fmt++;
X	} else {
X	    suppress = 0;
X	}
X	while (isdigit(*fmt)) {
X	    fmt++;
X	}
X	if (suppress) {
X	    continue;
X	}
X	if (numFields == MAX_FIELDS) {
X	    sprintf(interp->result,
X		    "can't have more than %d fields in \"%.50s\"", MAX_FIELDS,
X		    argv[0]);
X	    return TCL_ERROR;
X	}
X	curField = &fields[numFields];
X	numFields++;
X	switch (*fmt) {
X	    case 'D':
X	    case 'O':
X	    case 'X':
X	    case 'd':
X	    case 'o':
X	    case 'x':
X		curField->fmt = 'd';
X		curField->size = sizeof(int);
X		break;
X
X	    case 's':
X		curField->fmt = 's';
X		curField->size = arg1Length;
X		break;
X
X	    case 'c':
X		curField->fmt = 'c';
X		curField->size = sizeof(int);
X		break;
X
X	    case 'E':
X	    case 'F':
X		curField->fmt = 'F';
X		curField->size = 8;
X		break;
X
X	    case 'e':
X	    case 'f':
X		curField->fmt = 'f';
X		curField->size = 4;
X		break;
X
X	    case '[':
X		curField->fmt = 's';
X		curField->size = arg1Length;
X		do {
X		    fmt++;
X		} while (*fmt != ']');
X		break;
X
X	    default:
X		sprintf(interp->result, "bad scan conversion character \"%c\"",
X			*fmt);
X		return TCL_ERROR;
X	}
X	totalSize += curField->size;
X    }
X
X    if (numFields != (argc-3)) {
X	interp->result =
X		"different numbers of variable names and field specifiers";
X	return TCL_ERROR;
X    }
X
X    /*
X     * Step 2:
X     */
X
X    results = (char *) ckalloc((unsigned) totalSize);
X    for (i = 0, totalSize = 0, curField = fields;
X	    i < numFields; i++, curField++) {
X	curField->location = results + totalSize;
X	totalSize += curField->size;
X    }
X
X    /*
X     * Step 3:
X     */
X
X    numScanned = sscanf(argv[1], argv[2],
X	    fields[0].location, fields[1].location, fields[2].location,
X	    fields[3].location, fields[4].location);
X
X    /*
X     * Step 4:
X     */
X
X    if (numScanned < numFields) {
X	numFields = numScanned;
X    }
X    for (i = 0, curField = fields; i < numFields; i++, curField++) {
X	switch (curField->fmt) {
X	    char string[30];
X
X	    case 'd':
X		sprintf(string, "%d", *((int *) curField->location));
X		Tcl_SetVar(interp, argv[i+3], string, 0);
X		break;
X
X	    case 'c':
X		sprintf(string, "%d", *((char *) curField->location) & 0xff);
X		Tcl_SetVar(interp, argv[i+3], string, 0);
X		break;
X
X	    case 's':
X		Tcl_SetVar(interp, argv[i+3], curField->location, 0);
X		break;
X
X	    case 'F':
X		sprintf(string, "%g", *((double *) curField->location));
X		Tcl_SetVar(interp, argv[i+3], string, 0);
X		break;
X
X	    case 'f':
X		sprintf(string, "%g", *((float *) curField->location));
X		Tcl_SetVar(interp, argv[i+3], string, 0);
X		break;
X	}
X    }
X    ckfree(results);
X    sprintf(interp->result, "%d", numScanned);
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    int fileId, result;
X    struct stat statBuf;
X    char *cmdBuffer, *end;
X
X    if (argc != 2) {
X	sprintf(interp->result, "wrong # args: should be \"%.50s fileName\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    fileId = open(argv[1], O_RDONLY, 0);
X    if (fileId < 0) {
X	sprintf(interp->result, "couldn't read file \"%.50s\"", argv[1]);
X	return TCL_ERROR;
X    }
X    if (fstat(fileId, &statBuf) == -1) {
X	sprintf(interp->result, "couldn't stat file \"%.50s\"", argv[1]);
X	close(fileId);
X	return TCL_ERROR;
X    }
X    cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
X    if (read(fileId, cmdBuffer, (int) statBuf.st_size) != statBuf.st_size) {
X	sprintf(interp->result, "error in reading file \"%.50s\"", argv[1]);
X	close(fileId);
X	return TCL_ERROR;
X    }
X    close(fileId);
X    cmdBuffer[statBuf.st_size] = 0;
X    result = Tcl_Eval(interp, cmdBuffer, 0, &end);
X    if (result == TCL_RETURN) {
X	result = TCL_OK;
X    }
X    if (result == TCL_ERROR) {
X	char msg[100];
X
X	/*
X	 * Record information telling where the error occurred.
X	 */
X
X	sprintf(msg, " (file \"%.50s\" line %d)", argv[1], interp->errorLine);
X	Tcl_AddErrorInfo(interp, msg);
X    }
X    ckfree(cmdBuffer);
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StringCmd --
X *
X *	This procedure is invoked to process the "string" 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_StringCmd(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 length;
X    register char *p, c;
X    int match;
X    int first;
X
X    if (argc != 4) {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s option a b\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    length = strlen(argv[1]);
X    if (strncmp(argv[1], "compare", length) == 0) {
X	match = strcmp(argv[2], argv[3]);
X	if (match > 0) {
X	    interp->result = "1";
X	} else if (match < 0) {
X	    interp->result = "-1";
X	} else {
X	    interp->result = "0";
X	}
X	return TCL_OK;
X    }
X    if (strncmp(argv[1], "first", length) == 0) {
X	first = 1;
X    } else if (strncmp(argv[1], "last", length) == 0) {
X	first = 0;
X    } else if (strncmp(argv[1], "match", length) == 0) {
X	if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
X	    interp->result = "1";
X	} else {
X	    interp->result = "0";
X	}
X	return TCL_OK;
X    } else {
X	sprintf(interp->result,
X		"bad \"%.50s\" option \"%.50s\": must be compare, first, or last",
X		argv[0], argv[1]);
X	return TCL_ERROR;
X    }
X    match = -1;
X    c = *argv[2];
X    length = strlen(argv[2]);
X    for (p = argv[3]; *p != 0; p++) {
X	if (*p != c) {
X	    continue;
X	}
X	if (strncmp(argv[2], p, length) == 0) {
X	    match = p-argv[3];
X	    if (first) {
X		break;
X	    }
X	}
X    }
X    sprintf(interp->result, "%d", match);
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#ifdef BSD
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    double timePer;
X
X    if (argc == 2) {
X	count = 1;
X    } else if (argc == 3) {
X	if (sscanf(argv[2], "%d", &count) != 1) {
X	    sprintf(interp->result, "bad count \"%.50s\" given to \"%.50s\"",
X		    argv[2], argv[0]);
X	    return TCL_ERROR;
X	}
X    } else {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s command [count]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X#ifdef BSD
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, " (\"time\" body line %d)", interp->errorLine);
X		Tcl_AddErrorInfo(interp, msg);
X	    }
X	    return result;
X	}
X    }
X#ifdef BSD
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    ticks = stop-start;
X    timePer = ((double)ticks * 1000000.0) / HZ;
X#endif
X    Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X    sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
X    return TCL_OK;
X}
END_OF_FILE
if test 32065 -ne `wc -c <'tclCmdIZ.c'`; then
    echo shar: \"'tclCmdIZ.c'\" unpacked with wrong size!
fi
# end of 'tclCmdIZ.c'
fi
echo shar: End of archive 5 \(of 6\).
cp /dev/null ark5isdone
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


