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


Archive-name: tcl/Part03

#! /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 3 (of 6)."
# Contents:  tclProc.c tclUtil.c
# Wrapped by peter@ficc.uu.net on Wed Mar  7 05:16:07 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tclProc.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tclProc.c'\"
else
echo shar: Extracting \"'tclProc.c'\" \(22687 characters\)
sed "s/^X//" >'tclProc.c' <<'END_OF_FILE'
X/* 
X * tclProc.c --
X *
X *	This file contains routines that implement Tcl procedures and
X *	variables.
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/tclProc.c,v 1.31 90/01/27 14:44:24 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <stdio.h>
X#include <stdlib.h>
X#include <string.h>
X#include <ctype.h>
X#include "tclInt.h"
X
X/*
X * Forward references to procedures defined later in this file:
X */
X
Xextern Var *	FindVar();
Xextern int	InterpProc();
Xextern Var *	NewVar();
Xextern void	ProcDeleteProc();
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ProcCmd --
X *
X *	This procedure is invoked to process the "proc" Tcl command.
X *	See the user documentation for details on what it does.
X *
X * Results:
X *	A standard Tcl result value.
X *
X * Side effects:
X *	A new procedure gets created.
X *
X *----------------------------------------------------------------------
X */
X
X	/* ARGSUSED */
Xint
XTcl_ProcCmd(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    register Proc *procPtr;
X    int result, argCount, i;
X    char **argArray;
X
X    if (argc != 4) {
X	sprintf(iPtr->result,
X		"wrong # args: should be \"%.50s name args body\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X
X    procPtr = (Proc *) ckalloc(sizeof(Proc));
X    procPtr->iPtr = iPtr;
X    procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
X    strcpy(procPtr->command, argv[3]);
X    procPtr->argPtr = NULL;
X    Tcl_CreateCommand(interp, argv[1], InterpProc,
X	    (ClientData) procPtr, ProcDeleteProc);
X
X    /*
X     * Break up the argument list into argument specifiers, then process
X     * each argument specifier.
X     */
X
X    result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
X    if (result != TCL_OK) {
X	return result;
X    }
X    for (i = 0; i < argCount; i++) {
X	int fieldCount, nameLength, valueLength;
X	char **fieldValues;
X	register Var *argPtr;
X
X	/*
X	 * Now divide the specifier up into name and default.
X	 */
X
X	result = Tcl_SplitList(interp, argArray[i], &fieldCount,
X		&fieldValues);
X	if (result != TCL_OK) {
X	    goto procError;
X	}
X	if (fieldCount > 2) {
X	    sprintf(iPtr->result,
X		    "too many fields in argument specifier \"%.50s\"",
X		    argArray[i]);
X	    result = TCL_ERROR;
X	    goto procError;
X	}
X	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
X	    sprintf(iPtr->result,
X		    "procedure \"%.50s\" has argument with no name", argv[1]);
X	    result = TCL_ERROR;
X	    goto procError;
X	}
X	nameLength = strlen(fieldValues[0]);
X	if (fieldCount == 2) {
X	    valueLength = strlen(fieldValues[1]);
X	} else {
X	    valueLength = 0;
X	}
X	if (procPtr->argPtr == NULL) {
X	    argPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
X	    procPtr->argPtr = argPtr;
X	} else {
X	    argPtr->nextPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
X	    argPtr = argPtr->nextPtr;
X	}
X	strcpy(argPtr->name, fieldValues[0]);
X	if (fieldCount == 2) {
X	    argPtr->value = argPtr->name + nameLength + 1;
X	    strcpy(argPtr->value, fieldValues[1]);
X	} else {
X	    argPtr->value = NULL;
X	}
X	argPtr->valueLength = valueLength;
X	argPtr->flags = 0;
X	argPtr->nextPtr = NULL;
X	ckfree((char *) fieldValues);
X    }
X
X    ckfree((char *) argArray);
X    return TCL_OK;
X
X    procError:
X    ckfree((char *) argArray);
X    return result;
X}
X 
X/*1
X *----------------------------------------------------------------------
X *
X * Tcl_GetVar --
X *
X *	Return the value of a Tcl variable.
X *
X * Results:
X *	The return value points to the current value of varName.  If
X *	the variable is not defined in interp, either as a local or
X *	global variable, then a NULL pointer is returned.
X *
X *	Note:  the return value is only valid up until the next call to
X *	Tcl_SetVar;  if you depend on the value lasting longer than that,
X *	then make yourself a private copy.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_GetVar(interp, varName, global)
X    Tcl_Interp *interp;		/* Command interpreter in which varName is
X				 * to be looked up. */
X    char *varName;		/* Name of a variable in interp. */
X    int global;			/* If non-zero, use only a global variable */
X{
X    Var *varPtr;
X    Interp *iPtr = (Interp *) interp;
X
X    if (global || (iPtr->varFramePtr == NULL)) {
X	varPtr = FindVar(&iPtr->globalPtr, varName);
X    } else {
X	varPtr = FindVar(&iPtr->varFramePtr->varPtr, varName);
X    }
X    if (varPtr == NULL) {
X	return NULL;
X    }
X    if (varPtr->flags & VAR_GLOBAL) {
X	varPtr = varPtr->globalPtr;
X    }
X    if (varPtr->value == NULL) {
X	return "";
X    }
X    return varPtr->value;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetVar --
X *
X *	Change the value of a variable.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	If varName is defined as a local or global variable in interp,
X *	its value is changed to newValue.  If varName isn't currently
X *	defined, then a new global variable by that name is created.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_SetVar(interp, varName, newValue, global)
X    Tcl_Interp *interp;		/* Command interpreter in which varName is
X				 * to be looked up. */
X    char *varName;		/* Name of a variable in interp. */
X    char *newValue;		/* New value for varName. */
X    int global;			/* If non-zero, use only a global variable. */
X{
X    register Var *varPtr, **varListPtr;
X    register Interp *iPtr = (Interp *) interp;
X    int valueLength;
X
X    if (global || (iPtr->varFramePtr == NULL)) {
X	varListPtr = &iPtr->globalPtr;
X    } else {
X	varListPtr = &iPtr->varFramePtr->varPtr;
X    }
X    varPtr = FindVar(varListPtr, varName);
X    if (varPtr == NULL) {
X	varPtr = NewVar(varName, newValue);
X	varPtr->nextPtr = *varListPtr;
X	*varListPtr = varPtr;
X    } else {
X	if (varPtr->flags & VAR_GLOBAL) {
X	    varPtr = varPtr->globalPtr;
X	}
X	valueLength = strlen(newValue);
X	if (valueLength > varPtr->valueLength) {
X	    if (varPtr->flags & VAR_DYNAMIC) {
X		ckfree(varPtr->value);
X	    }
X	    varPtr->value = (char *) ckalloc((unsigned) valueLength + 1);
X	    varPtr->flags |= VAR_DYNAMIC;
X	    varPtr->valueLength = valueLength;
X	}
X	strcpy(varPtr->value, newValue);
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ParseVar --
X *
X *	Given a string starting with a $ sign, parse off a variable
X *	name and return its value.
X *
X * Results:
X *	The return value is the contents of the variable given by
X *	the leading characters of string.  If termPtr isn't NULL,
X *	*termPtr gets filled in with the address of the character
X *	just after the last one in the variable specifier.  If the
X *	variable doesn't exist, then the return value is NULL and
X *	an error message will be left in interp->result.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_ParseVar(interp, string, termPtr)
X    Tcl_Interp *interp;			/* Context for looking up variable. */
X    register char *string;		/* String containing variable name.
X					 * First character must be "$". */
X    char **termPtr;			/* If non-NULL, points to word to fill
X					 * in with character just after last
X					 * one in the variable specifier. */
X
X{
X    char *name, c, *result;
X
X    /*
X     * There are two cases:
X     * 1. The $ sign is followed by an open curly brace.  Then the variable
X     *    name is everything up to the next close curly brace.
X     * 2. The $ sign is not followed by an open curly brace.  Then the
X     *    variable name is everything up to the next character that isn't
X     *    a letter, digit, or underscore.
X     */
X
X    string++;
X    if (*string == '{') {
X	string++;
X	name = string;
X	while ((*string != '}') && (*string != 0)) {
X	    string++;
X	}
X	if (termPtr != 0) {
X	    if (*string != 0) {
X		*termPtr = string+1;
X	    } else {
X		*termPtr = string;
X	    }
X	}
X    } else {
X	name = string;
X	while (isalnum(*string) || (*string == '_')) {
X	    string++;
X	}
X	if (termPtr != 0) {
X	    *termPtr = string;
X	}
X    }
X
X    c = *string;
X    *string = 0;
X    result = Tcl_GetVar(interp, name, 0);
X    if (!result) {
X	Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X	sprintf(interp->result, "couldn't find variable \"%.50s\"", name);
X    }
X    *string = c;
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetCmd --
X *
X *	This procedure is invoked to process the "set" Tcl command.
X *	See the user documentation for details on what it does.
X *
X * Results:
X *	A standard Tcl result value.
X *
X * Side effects:
X *	A variable's value may be changed.
X *
X *----------------------------------------------------------------------
X */
X
X	/* ARGSUSED */
Xint
XTcl_SetCmd(dummy, interp, argc, argv)
X    ClientData dummy;			/* Not used. */
X    register Tcl_Interp *interp;	/* Current interpreter. */
X    int argc;				/* Number of arguments. */
X    char **argv;			/* Argument strings. */
X{
X    if (argc == 2) {
X	char *value;
X
X	value = Tcl_GetVar(interp, argv[1], 0);
X	if (value == 0) {
X	    sprintf(interp->result, "couldn't find variable \"%.50s\"",
X		    argv[1]);
X	    return TCL_ERROR;
X	}
X	interp->result = value;
X	return TCL_OK;
X    } else if (argc == 3) {
X	Tcl_SetVar(interp, argv[1], argv[2], 0);
X	return TCL_OK;
X    } else {
X	sprintf(interp->result,
X		"wrong # args: should be \"%.50s varName [newValue]\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GlobalCmd --
X *
X *	This procedure is invoked to process the "global" Tcl command.
X *	See the user documentation for details on what it does.
X *
X * Results:
X *	A standard Tcl result value.
X *
X * Side effects:
X *	See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X	/* ARGSUSED */
Xint
XTcl_GlobalCmd(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 Var *varPtr;
X    register Interp *iPtr = (Interp *) interp;
X    Var *gVarPtr;
X
X    if (argc < 2) {
X	sprintf(iPtr->result,
X		"too few args:  should be \"%.50s varName varName ...\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    if (iPtr->varFramePtr == NULL) {
X	return TCL_OK;
X    }
X
X    for (argc--, argv++; argc > 0; argc--, argv++) {
X	gVarPtr = FindVar(&iPtr->globalPtr, *argv);
X	if (gVarPtr == NULL) {
X	    gVarPtr = NewVar(*argv, "");
X	    gVarPtr->nextPtr = iPtr->globalPtr;
X	    iPtr->globalPtr = gVarPtr;
X	}
X	varPtr = NewVar(*argv, "");
X	varPtr->flags |= VAR_GLOBAL;
X	varPtr->globalPtr = gVarPtr;
X	varPtr->nextPtr = iPtr->varFramePtr->varPtr;
X	iPtr->varFramePtr->varPtr = varPtr;
X    }
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UplevelCmd --
X *
X *	This procedure is invoked to process the "uplevel" Tcl command.
X *	See the user documentation for details on what it does.
X *
X * Results:
X *	A standard Tcl result value.
X *
X * Side effects:
X *	See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X	/* ARGSUSED */
Xint
XTcl_UplevelCmd(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    int level, result;
X    char *end;
X    CallFrame *savedVarFramePtr, *framePtr;
X
X    if (argc < 3) {
X	sprintf(iPtr->result,
X		"too few args:  should be \"%.50s level command ...\"",
X		argv[0]);
X	return TCL_ERROR;
X    }
X    level = strtol(argv[1], &end, 10);
X    if ((end == argv[1]) || (*end != '\0')) {
X	levelError:
X	sprintf(iPtr->result, "bad level \"%.50s\"", argv[1]);
X	return TCL_ERROR;
X    }
X
X    /*
X     * Figure out which frame to use, and modify the interpreter so
X     * its variables come from that frame.
X     */
X
X    savedVarFramePtr = iPtr->varFramePtr;
X    if (level < 0) {
X	if (savedVarFramePtr == NULL) {
X	    goto levelError;
X	}
X	level += savedVarFramePtr->level;
X    }
X    if (level == 0) {
X	iPtr->varFramePtr = NULL;
X    } else {
X	for (framePtr = savedVarFramePtr; 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->varFramePtr = framePtr;
X    }
X
X    /*
X     * Execute the residual arguments as a command.
X     */
X
X    if (argc == 3) {
X	result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
X    } else {
X	char *cmd;
X
X	cmd = Tcl_Concat(argc-2, argv+2);
X	result = Tcl_Eval(interp, cmd, 0, (char **) NULL);
X    }
X    if (result == TCL_ERROR) {
X	char msg[60];
X	sprintf(msg, " (\"uplevel\" body line %d)", interp->errorLine);
X	Tcl_AddErrorInfo(interp, msg);
X    }
X
X    /*
X     * Restore the variable frame, and return.
X     */
X
X    iPtr->varFramePtr = savedVarFramePtr;
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclFindProc --
X *
X *	Given the name of a procedure, return a pointer to the
X *	record describing the procedure.
X *
X * Results:
X *	NULL is returned if the name doesn't correspond to any
X *	procedure.  Otherwise the return value is a pointer to
X *	the procedure's record.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
XProc *
XTclFindProc(iPtr, procName)
X    Interp *iPtr;		/* Interpreter in which to look. */
X    char *procName;		/* Name of desired procedure. */
X{
X    Command *cmdPtr;
X
X    cmdPtr = TclFindCmd(iPtr, procName, 0);
X    if (cmdPtr == NULL) {
X	return NULL;
X    }
X    if (cmdPtr->proc != InterpProc) {
X	return NULL;
X    }
X    return (Proc *) cmdPtr->clientData;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclIsProc --
X *
X *	Tells whether a command is a Tcl procedure or not.
X *
X * Results:
X *	If the given command is actuall a Tcl procedure, the
X *	return value is the address of the record describing
X *	the procedure.  Otherwise the return value is 0.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
XProc *
XTclIsProc(cmdPtr)
X    Command *cmdPtr;		/* Command to test. */
X{
X    if (cmdPtr->proc == InterpProc) {
X	return (Proc *) cmdPtr->clientData;
X    }
X    return (Proc *) 0;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclDeleteVars --
X *
X *	This procedure is called as part of deleting an interpreter:
X *	it recycles all the storage space associated with global
X *	variables (the local ones should already have been deleted).
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	Variables are deleted.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTclDeleteVars(iPtr)
X    Interp *iPtr;		/* Interpreter to nuke. */
X{
X    register Var *varPtr;
X
X    for (varPtr = iPtr->globalPtr; varPtr != NULL; varPtr = varPtr->nextPtr) {
X	if (varPtr->flags & VAR_DYNAMIC) {
X	    ckfree(varPtr->value);
X	}
X	ckfree((char *) varPtr);
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * InterpProc --
X *
X *	When a Tcl procedure gets invoked, this routine gets invoked
X *	to interpret the procedure.
X *
X * Results:
X *	A standard Tcl result value, usually TCL_OK.
X *
X * Side effects:
X *	Depends on the commands in the procedure.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XInterpProc(procPtr, interp, argc, argv)
X    register Proc *procPtr;	/* Record describing procedure to be
X				 * interpreted. */
X    Tcl_Interp *interp;		/* Interpreter in which procedure was
X				 * invoked. */
X    int argc;			/* Count of number of arguments to this
X				 * procedure. */
X    char **argv;		/* Argument values. */
X{
X    char **args;
X    register Var *formalPtr, *argPtr;
X    register Interp *iPtr = (Interp *) interp;
X    CallFrame frame;
X    char *value, *end;
X    int result;
X
X    /*
X     * Set up a call frame for the new procedure invocation.
X     */
X
X    iPtr = procPtr->iPtr;
X    frame.varPtr = NULL;
X    if (iPtr->varFramePtr != NULL) {
X	frame.level = iPtr->varFramePtr->level + 1;
X    } else {
X	frame.level = 1;
X    }
X    frame.argc = argc;
X    frame.argv = argv;
X    frame.callerPtr = iPtr->framePtr;
X    frame.callerVarPtr = iPtr->varFramePtr;
X    iPtr->framePtr = &frame;
X    iPtr->varFramePtr = &frame;
X
X    /*
X     * Match the actual arguments against the procedure's formal
X     * parameters to compute local variables.
X     */
X
X    for (formalPtr = procPtr->argPtr, args = argv+1, argc -= 1;
X	    formalPtr != NULL;
X	    formalPtr = formalPtr->nextPtr, args++, argc--) {
X
X	/*
X	 * Handle the special case of the last formal being "args".  When
X	 * it occurs, assign it a list consisting of all the remaining
X	 * actual arguments.
X	 */
X
X	if ((formalPtr->nextPtr == NULL)
X		&& (strcmp(formalPtr->name, "args") == 0)) {
X	    if (argc < 0) {
X		argc = 0;
X	    }
X	    value = Tcl_Merge(argc, args);
X	    argPtr = NewVar(formalPtr->name, value);
X	    ckfree(value);
X	    argPtr->nextPtr = frame.varPtr;
X	    frame.varPtr = argPtr;
X	    argc = 0;
X	    break;
X	} else if (argc > 0) {
X	    value = *args;
X	} else if (formalPtr->value != NULL) {
X	    value = formalPtr->value;
X	} else {
X	    sprintf(iPtr->result,
X		    "no value given for parameter \"%s\" to \"%s\"",
X		    formalPtr->name, argv[0]);
X	    result = TCL_ERROR;
X	    goto procDone;
X	}
X	argPtr = NewVar(formalPtr->name, value);
X	argPtr->nextPtr = frame.varPtr;
X	frame.varPtr = argPtr;
X    }
X    if (argc > 0) {
X	sprintf(iPtr->result, "called \"%s\" with too many arguments",
X		argv[0]);
X	result = TCL_ERROR;
X	goto procDone;
X    }
X
X    /*
X     * Invoke the commands in the procedure's body.
X     */
X
X    result = Tcl_Eval(interp, procPtr->command, 0, &end);
X    if (result == TCL_RETURN) {
X	result = TCL_OK;
X    } else if (result == TCL_ERROR) {
X	char msg[100];
X
X	/*
X	 * Record information telling where the error occurred.
X	 */
X
X	sprintf(msg, " (procedure \"%.50s\" line %d)", argv[0],
X		iPtr->errorLine);
X	Tcl_AddErrorInfo(interp, msg);
X    } else if (result == TCL_BREAK) {
X	iPtr->result = "invoked \"break\" outside of a loop";
X	result = TCL_ERROR;
X    } else if (result == TCL_CONTINUE) {
X	iPtr->result = "invoked \"continue\" outside of a loop";
X	result = TCL_ERROR;
X    }
X
X    /*
X     * Delete the call frame for this procedure invocation.
X     */
X
X    procDone:
X    for (argPtr = frame.varPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
X	if (argPtr->flags & VAR_DYNAMIC) {
X	    ckfree(argPtr->value);
X	}
X	ckfree((char *) argPtr);
X    }
X    iPtr->framePtr = frame.callerPtr;
X    iPtr->varFramePtr = frame.callerVarPtr;
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * ProcDeleteProc --
X *
X *	This procedure is invoked just before a command procedure is
X *	removed from an interpreter.  Its job is to release all the
X *	resources allocated to the procedure.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	Memory gets freed.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XProcDeleteProc(procPtr)
X    register Proc *procPtr;		/* Procedure to be deleted. */
X{
X    register Var *argPtr;
X
X    ckfree((char *) procPtr->command);
X    for (argPtr = procPtr->argPtr; argPtr != NULL; argPtr = argPtr->nextPtr) {
X	if (argPtr->flags & VAR_DYNAMIC) {
X	    ckfree(argPtr->value);
X	}
X	ckfree((char *) argPtr);
X    }
X    ckfree((char *) procPtr);
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * FindVar --
X *
X *	Locate the Var structure corresponding to varName, if there
X *	is one defined in a given list.
X *
X * Results:
X *	The return value points to the Var structure corresponding to
X *	the current value of varName in varListPtr, or NULL if varName
X *	isn't currently defined in the list.
X *
X * Side effects:
X *	If the variable is found, it is moved to the front of the list.
X *
X *----------------------------------------------------------------------
X */
X
XVar *
XFindVar(varListPtr, varName)
X    Var **varListPtr;		/* Pointer to head of list.  The value pointed
X				 * to will be modified to bring the found
X				 * variable to the front of the list. */
X    char *varName;		/* Desired variable. */
X{
X    register Var *prev, *cur;
X    register char c;
X
X    c = *varName;
X
X    /*
X     * Local variables take precedence over global ones.  Check the
X     * first character immediately, before wasting time calling strcmp.
X     */
X
X    for (prev = NULL, cur = *varListPtr; cur != NULL;
X	    prev = cur, cur = cur->nextPtr) {
X	if ((cur->name[0] == c) && (strcmp(cur->name, varName) == 0)) {
X	    if (prev != NULL) {
X		prev->nextPtr = cur->nextPtr;
X		cur->nextPtr = *varListPtr;
X		*varListPtr = cur;
X	    }
X	    return cur;
X	}
X    }
X    return NULL;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * NewVar --
X *
X *	Create a new variable with the given name and initial value.
X *
X * Results:
X *	The return value is a pointer to the new variable.  The variable
X *	will not have been linked into any particular list, and its
X *	nextPtr field will be NULL.
X *
X * Side effects:
X *	Storage gets allocated.
X *
X *----------------------------------------------------------------------
X */
X
XVar *
XNewVar(name, value)
X    char *name;			/* Name for variable. */
X    char *value;		/* Value for variable. */
X{
X    register Var *varPtr;
X    int nameLength, valueLength;
X
X    nameLength = strlen(name);
X    valueLength = strlen(value);
X    if (valueLength < 20) {
X	valueLength = 20;
X    }
X    varPtr = (Var *) ckalloc(VAR_SIZE(nameLength, valueLength));
X    strcpy(varPtr->name, name);
X    varPtr->value = varPtr->name + nameLength + 1;
X    strcpy(varPtr->value, value);
X    varPtr->valueLength = valueLength;
X    varPtr->flags = 0;
X    varPtr->globalPtr = NULL;
X    varPtr->nextPtr = NULL;
X    return varPtr;
X}
END_OF_FILE
if test 22687 -ne `wc -c <'tclProc.c'`; then
    echo shar: \"'tclProc.c'\" unpacked with wrong size!
fi
# end of 'tclProc.c'
fi
if test -f 'tclUtil.c' -a "${1}" != "-c" ; then 
  echo shar: Will not clobber existing file \"'tclUtil.c'\"
else
echo shar: Extracting \"'tclUtil.c'\" \(21835 characters\)
sed "s/^X//" >'tclUtil.c' <<'END_OF_FILE'
X/* 
X * tclUtil.c --
X *
X *	This file contains utility procedures that are used by many Tcl
X *	commands.
X *
X * Copyright 1987, 1989 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/tclUtil.c,v 1.27 90/01/07 12:05:20 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <ctype.h>
X#include <stdio.h>
X#include <stdlib.h>
X#include <string.h>
X#include "tcl.h"
X#include "tclInt.h"
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclFindElement --
X *
X *	Given a pointer into a Tcl list, locate the first (or next)
X *	element in the list.
X *
X * Results:
X *	The return value is normally TCL_OK, which means that the
X *	element was successfully located.  If TCL_ERROR is returned
X *	it means that list didn't have proper list structure;
X *	interp->result contains a more detailed error message.
X *
X *	If TCL_OK is returned, then *elementPtr will be set to point
X *	to the first element of list, and *nextPtr will be set to point
X *	to the character just after any white space following the last
X *	character that's part of the element.  If this is the last argument
X *	in the list, then *nextPtr will point to the NULL character at the
X *	end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
X *	the number of characters in the element.  If the element is in
X *	braces, then *elementPtr will point to the character after the
X *	opening brace and *sizePtr will not include either of the braces.
X *	If there isn't an element in the list, *sizePtr will be zero, and
X *	both *elementPtr and *termPtr will refer to the null character at
X *	the end of list.  Note:  this procedure does NOT collapse backslash
X *	sequences.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
X    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
X    register char *list;	/* String containing Tcl list with zero
X				 * or more elements (possibly in braces). */
X    char **elementPtr;		/* Fill in with location of first significant
X				 * character in first element of list. */
X    char **nextPtr;		/* Fill in with location of character just
X				 * after all white space following end of
X				 * argument (i.e. next argument or end of
X				 * list). */
X    int *sizePtr;		/* If non-zero, fill in with size of
X				 * element. */
X    int *bracePtr;		/* If non-zero fill in with non-zero/zero
X				 * to indicate that arg was/wasn't
X				 * in braces. */
X{
X    register char *p;
X    int openBraces = 0;
X    int size;
X
X    /*
X     * Skim off leading white space and check for an opening brace.
X     */
X
X    while (isspace(*list)) {
X	list++;
X    }
X    if (*list == '{') {
X	openBraces = 1;
X	list++;
X    }
X    if (bracePtr != 0) {
X	*bracePtr = openBraces;
X    }
X    p = list;
X
X    /*
X     * Find the end of the element (either a space or a close brace or
X     * the end of the string).
X     */
X
X    while (1) {
X	switch (*p) {
X
X	    /*
X	     * Open brace: don't treat specially unless the element is
X	     * in braces.  In this case, keep a nesting count.
X	     */
X
X	    case '{':
X		if (openBraces != 0) {
X		    openBraces++;
X		}
X		break;
X
X	    /*
X	     * Close brace: if element is in braces, keep nesting
X	     * count and quit when the last close brace is seen.
X	     */
X
X	    case '}':
X		if (openBraces == 1) {
X		    char *p2;
X
X		    size = p - list;
X		    p++;
X		    if (isspace(*p) || (*p == 0)) {
X			goto done;
X		    }
X		    for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
X			    p2++) {
X			/* null body */
X		    }
X		    Tcl_Return(interp, (char *) NULL, TCL_STATIC);
X		    sprintf(interp->result,
X			    "list element in braces followed by \"%.*s\" instead of space",
X			    p2-p, p);
X		    return TCL_ERROR;
X		} else if (openBraces != 0) {
X		    openBraces--;
X		}
X		break;
X
X	    /*
X	     * Backslash:  skip over everything up to the end of the
X	     * backslash sequence.
X	     */
X
X	    case '\\': {
X		int size;
X
X		(void) Tcl_Backslash(p, &size);
X		p += size - 1;
X		break;
X	    }
X
X	    /*
X	     * Space: ignore if element is in braces;  otherwise
X	     * terminate element.
X	     */
X
X	    case ' ':
X	    case '\t':
X	    case '\n':
X		if (openBraces == 0) {
X		    size = p - list;
X		    goto done;
X		}
X		break;
X
X	    /*
X	     * End of list:  terminate element.
X	     */
X
X	    case 0:
X		if (openBraces != 0) {
X		    Tcl_Return(interp, "unmatched open brace in list",
X			    TCL_STATIC);
X		    return TCL_ERROR;
X		}
X		size = p - list;
X		goto done;
X
X	}
X	p++;
X    }
X
X    done:
X    while (isspace(*p)) {
X	p++;
X    }
X    *elementPtr = list;
X    *nextPtr = p;
X    if (sizePtr != 0) {
X	*sizePtr = size;
X    }
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * TclCopyAndCollapse --
X *
X *	Copy a string and eliminate any backslashes that aren't in braces.
X *
X * Results:
X *	There is no return value.  Count chars. get copied from src
X *	to dst.  Along the way, if backslash sequences are found outside
X *	braces, the backslashes are eliminated in the copy.
X *	After scanning count chars. from source, a null character is
X *	placed at the end of dst.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTclCopyAndCollapse(count, src, dst)
X    register char *src;		/* Copy from here... */
X    register char *dst;		/* ... to here. */
X{
X    register char c;
X    int numRead;
X
X    for (c = *src; count > 0; dst++, src++, c = *src, count--) {
X	if (c == '\\') {
X	    *dst = Tcl_Backslash(src, &numRead);
X	    src += numRead-1;
X	    count -= numRead-1;
X	} else {
X	    *dst = c;
X	}
X    }
X    *dst = 0;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Merge --
X *
X *	Given a collection of strings, merge them together into a
X *	single string that has proper Tcl list structured (i.e.
X *	TclFindElement and TclCopyAndCollapse may be used to retrieve
X *	strings equal to the original elements, and Tcl_Eval will
X *	parse the string back into its original elements).
X *
X * Results:
X *	The return value is the address of a dynamically-allocated
X *	string containing the merged list.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_Merge(argc, argv)
X    int argc;			/* How many strings to merge. */
X    char **argv;		/* Array of string values. */
X{
X    /*
X     * This procedure operates in two passes.  In the first pass it figures
X     * out how many bytes will be needed to store the result (actually,
X     * it overestimates slightly).  The first pass also collects information
X     * about each element in the form of a flags word.  If there are only
X     * a few elements, local storage gets used for the flags;  if there are
X     * a lot of elements, a new array is dynamically allocated.
X     *
X     * In the second pass this procedure copies the arguments into the
X     * result string.  The special cases to worry about are:
X     *
X     * 1. Argument contains embedded spaces, or starts with a brace:  must
X     * add another level of braces when copying to the result.
X     *
X     * 2. Argument contains unbalanced braces:  backslash all of the
X     * braces when copying to the result.  In this case, don't add another
X     * level of braces (they would prevent the backslash from
X     * being removed when the argument is extracted from the list later).
X     *
X     * 3. Argument contains backslashed brace/bracket:  if possible,
X     * group the argument in braces:  then no special action needs to be taken
X     * with the backslashes.  If the argument can't be put in braces, then
X     * add another backslash in front of the sequence, so that upon
X     * extraction the original sequence will be restored.
X     *
X     * These potential problems are the reasons why particular information
X     * is gathered during pass 1.
X     */
X#   define WANT_PARENS			1
X#   define PARENS_UNBALANCED		2
X#   define PARENTHESIZED		4
X#   define CANT_PARENTHESIZE		8
X
X#   define LOCAL_SIZE 20
X    int localFlags[LOCAL_SIZE];
X    int *flagPtr;
X    int numChars;
X    char *result;
X    register char *src, *dst;
X    register int curFlags;
X    int i;
X
X    /*
X     * Pass 1: estimate space, gather information.
X     */
X
X    if (argc <= LOCAL_SIZE) {
X	flagPtr = localFlags;
X    } else {
X	flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
X    }
X    numChars = 0;
X    for (i = 0; i < argc; i++) {
X	int braceCount, nestingLevel, nestedBS, whiteSpace, brackets, dollars;
X
X	curFlags = braceCount = nestingLevel = nestedBS = whiteSpace = 0;
X	brackets = dollars = 0;
X	src = argv[i];
X	if (*src == '{') {
X	    curFlags |= PARENTHESIZED|WANT_PARENS;
X	}
X	if (*src == 0) {
X	    curFlags |= WANT_PARENS;
X	} else {
X	    for (; ; src++) {
X		switch (*src) {
X		    case '{':
X			braceCount++;
X			nestingLevel++;
X			break;
X		    case '}':
X			braceCount++;
X			nestingLevel--;
X			break;
X		    case ']':
X		    case '[':
X			curFlags |= WANT_PARENS;
X			brackets++;
X			break;
X		    case '$':
X			curFlags |= WANT_PARENS;
X			dollars++;
X			break;
X		    case ' ':
X		    case '\n':
X		    case '\t':
X			curFlags |= WANT_PARENS;
X			whiteSpace++;
X			break;
X		    case '\\':
X			src++;
X			if (*src == 0) {
X			    goto elementDone;
X			} else if ((*src == '{') || (*src == '}')
X				|| (*src == '[') || (*src == ']')) {
X			    curFlags |= WANT_PARENS;
X			    nestedBS++;
X			}
X			break;
X		    case 0:
X			goto elementDone;
X		}
X	    }
X	}
X	elementDone:
X	numChars += src - argv[i];
X	if (nestingLevel != 0) {
X	    numChars += braceCount + nestedBS + whiteSpace
X		    + brackets + dollars;
X	    curFlags = CANT_PARENTHESIZE;
X	}
X	if (curFlags & WANT_PARENS) {
X	    numChars += 2;
X	}
X	numChars++;		/* Space to separate arguments. */
X	flagPtr[i] = curFlags;
X    }
X
X    /*
X     * Pass two: copy into the result area.
X     */
X
X    result = (char *) ckalloc((unsigned) numChars + 1);
X    dst = result;
X    for (i = 0; i < argc; i++) {
X	curFlags = flagPtr[i];
X	if (curFlags & WANT_PARENS) {
X	    *dst = '{';
X	    dst++;
X	}
X	for (src = argv[i]; *src != 0 ; src++) {
X	    if (curFlags & CANT_PARENTHESIZE) {
X		switch (*src) {
X		    case '{':
X		    case '}':
X		    case ']':
X		    case '[':
X		    case '$':
X		    case ' ':
X			*dst = '\\';
X			dst++;
X			break;
X		    case '\n':
X			*dst = '\\';
X			dst++;
X			*dst = 'n';
X			goto loopBottom;
X		    case '\t':
X			*dst = '\\';
X			dst++;
X			*dst = 't';
X			goto loopBottom;
X		    case '\\':
X			*dst = '\\';
X			dst++;
X			src++;
X			if ((*src == '{') || (*src == '}') || (*src == '[')
X				|| (*src == ']')) {
X			    *dst = '\\';
X			    dst++;
X			} else if (*src == 0) {
X			    goto pass2ElementDone;
X			}
X			break;
X		}
X	    }
X	    *dst = *src;
X	    loopBottom:
X	    dst++;
X	}
X	pass2ElementDone:
X	if (curFlags & WANT_PARENS) {
X	    *dst = '}';
X	    dst++;
X	}
X	*dst = ' ';
X	dst++;
X    }
X    if (dst == result) {
X	*dst = 0;
X    } else {
X	dst[-1] = 0;
X    }
X
X    if (flagPtr != localFlags) {
X	ckfree((char *) flagPtr);
X    }
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Concat --
X *
X *	Concatenate a set of strings into a single large string.
X *
X * Results:
X *	The return value is dynamically-allocated string containing
X *	a concatenation of all the strings in argv, with spaces between
X *	the original argv elements.
X *
X * Side effects:
X *	Memory is allocated for the result;  the caller is responsible
X *	for freeing the memory.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_Concat(argc, argv)
X    int argc;			/* Number of strings to concatenate. */
X    char **argv;		/* Array of strings to concatenate. */
X{
X    int totalSize, i;
X    register char *p;
X    char *result;
X
X    for (totalSize = 1, i = 0; i < argc; i++) {
X	totalSize += strlen(argv[i]) + 1;
X    }
X    result = (char *)ckalloc((unsigned) totalSize);
X    for (p = result, i = 0; i < argc; i++) {
X	(void) strcpy(p, argv[i]);
X	p += strlen(argv[i]);
X	*p = ' ';
X	p++;
X    }
X    p[-1] = 0;
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Return --
X *
X *	Arrange for "string" to be the Tcl return value.
X *
X * Results:
X *	None.
X *
X * Side effects:
X *	interp->result is left pointing either to "string" (if "copy" is 0)
X *	or to a copy of string.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_Return(interp, string, status)
X    Tcl_Interp *interp;		/* Interpreter with which to associate the
X				 * return value. */
X    char *string;		/* Value to be returned.  If NULL,
X				 * the result is set to an empty string. */
X    int status;			/* Gives information about the string:
X				 * TCL_STATIC, TCL_DYNAMIC, TCL_VOLATILE.
X				 * Ignored if string is NULL. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int length;
X    int wasDynamic = iPtr->dynamic;
X    char *oldResult = iPtr->result;
X
X    if (string == NULL) {
X	iPtr->resultSpace[0] = 0;
X	iPtr->result = iPtr->resultSpace;
X	iPtr->dynamic = 0;
X    } else if (status == TCL_STATIC) {
X	iPtr->result = string;
X	iPtr->dynamic = 0;
X    } else if (status == TCL_DYNAMIC) {
X	iPtr->result = string;
X	iPtr->dynamic = 1;
X    } else {
X	length = strlen(string);
X	if (length > TCL_RESULT_SIZE) {
X	    iPtr->result = (char *) ckalloc((unsigned) length+1);
X	    iPtr->dynamic = 1;
X	} else {
X	    iPtr->dynamic = 0;
X	}
X	strcpy(iPtr->result, string);
X    }
X
X    /*
X     * If the old result was dynamically-allocated, ckfree it up.  Do it
X     * here, rather than at the beginning, in case the new result value
X     * was part of the old result value.
X     */
X
X    if (wasDynamic) {
X	ckfree(oldResult);
X    }
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Backslash --
X *
X *	Figure out how to handle a backslash sequence.
X *
X * Results:
X *	The return value is the character that should be substituted
X *	in place of the backslash sequence that starts at src.  If
X *	readPtr isn't NULL then it is filled in with a count of the
X *	number of characters in the backslash sequence.  Note:  if
X *	the backslash isn't followed by characters that are understood
X *	here, then the backslash sequence is only considered to be
X *	one character long, and it is replaced by a backslash char.
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar
XTcl_Backslash(src, readPtr)
X    char *src;			/* Points to the backslash character of
X				 * a backslash sequence. */
X    int *readPtr;		/* Fill in with number of characters read
X				 * from src, unless NULL. */
X{
X    register char *p = src+1;
X    char result;
X    int count;
X
X    count = 2;
X
X    switch (*p) {
X	case 'b':
X	    result = '\b';
X	    break;
X	case 'e':
X	    result = 033;
X	    break;
X	case 'n':
X	    result = '\n';
X	    break;
X	case 't':
X	    result = '\t';
X	    break;
X	case 'C':
X	    p++;
X	    if (isspace(*p) || (*p == 0)) {
X		result = 'C';
X		count = 1;
X		break;
X	    }
X	    count = 3;
X	    if (*p == 'M') {
X		p++;
X		if (isspace(*p) || (*p == 0)) {
X		    result = 'M' & 037;
X		    break;
X		}
X		count = 4;
X		result = (*p & 037) | 0200;
X		break;
X	    }
X	    count = 3;
X	    result = *p & 037;
X	    break;
X	case 'M':
X	    p++;
X	    if (isspace(*p) || (*p == 0)) {
X		result = 'M';
X		count = 1;
X		break;
X	    }
X	    count = 3;
X	    result = *p + 0200;
X	    break;
X	case '}':
X	case '{':
X	case ']':
X	case '[':
X	case '$':
X	case ' ':
X	case ';':
X	case '"':
X	case '\\':
X	    result = *p;
X	    break;
X	default:
X	    if (isdigit(*p)) {
X		result = *p - '0';
X		p++;
X		if (!isdigit(*p)) {
X		    break;
X		}
X		count = 3;
X		result = (result << 3) + (*p - '0');
X		p++;
X		if (!isdigit(*p)) {
X		    break;
X		}
X		count = 4;
X		result = (result << 3) + (*p - '0');
X		break;
X	    }
X	    result = '\\';
X	    count = 1;
X	    break;
X    }
X
X    if (readPtr != NULL) {
X	*readPtr = count;
X    }
X    return result;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SplitList --
X *
X *	Splits a list up into its constituent fields.
X *
X * Results
X *	The return value is normally TCL_OK, which means that
X *	the list was successfully split up.  If TCL_ERROR is
X *	returned, it means that "list" didn't have proper list
X *	structure;  interp->result will contain a more detailed
X *	error message.
X *
X *	*argvPtr will be filled in with the address of an array
X *	whose elements point to the elements of list, in order.
X *	*argcPtr will get filled in with the number of valid elements
X *	in the array.  A single block of memory is dynamically allocated
X *	to hold both the argv array and a copy of the list (with
X *	backslashes and braces removed in the standard way).
X *	The caller must eventually ckfree this memory by calling ckfree()
X *	on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
X *	if the procedure returns normally.
X *
X * Side effects:
X *	Memory is allocated.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_SplitList(interp, list, argcPtr, argvPtr)
X    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
X    char *list;			/* Pointer to string with list structure. */
X    int *argcPtr;		/* Pointer to location to fill in with
X				 * the number of elements in the list. */
X    char ***argvPtr;		/* Pointer to place to store pointer to array
X				 * of pointers to list elements. */
X{
X    char **argv;
X    register char *p;
X    int size, i, result, elSize, brace;
X    char *element;
X
X    /*
X     * Figure out how much space to allocate.  There must be enough
X     * space for both the array of pointers and also for a copy of
X     * the list.  To estimate the number of pointers needed, count
X     * the number of space characters in the list.
X     */
X
X    for (size = 1, p = list; *p != 0; p++) {
X	if (isspace(*p)) {
X	    size++;
X	}
X    }
X    argv = (char **) ckalloc((unsigned)
X	    ((size * sizeof(char *)) + (p - list) + 1));
X    for (i = 0, p = ((char *) argv) + size*sizeof(char *);
X	    *list != 0; i++) {
X	result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
X	if (result != TCL_OK) {
X	    ckfree((char *) argv);
X	    return result;
X	}
X	if (*element == 0) {
X	    break;
X	}
X	if (i >= size) {
X	    Tcl_Return(interp, "internal error in Tcl_SplitList", TCL_STATIC);
X	    return TCL_ERROR;
X	}
X	argv[i] = p;
X	if (brace) {
X	    strncpy(p, element, elSize);
X	    p += elSize;
X	    *p = 0;
X	    p++;
X	} else {
X	    TclCopyAndCollapse(elSize, element, p);
X	    p += elSize+1;
X	}
X    }
X
X    *argvPtr = argv;
X    *argcPtr = i;
X    return TCL_OK;
X}
X 
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StringMatch --
X *
X *	See if a particular string matches a particular pattern.
X *
X * Results:
X *	The return value is 1 if string matches pattern, and
X *	0 otherwise.  The matching operation permits the following
X *	special characters in the pattern: *?\[] (see the manual
X *	entry for details on what these mean).
X *
X * Side effects:
X *	None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_StringMatch(string, pattern)
X    register char *string;	/* String. */
X    register char *pattern;	/* Pattern, which may contain
X				 * special characters. */
X{
X    char c2;
X
X    while (1) {
X	/* See if we're at the end of both the pattern and the string.
X	 * If so, we succeeded.  If we're at the end of the pattern
X	 * but not at the end of the string, we failed.
X	 */
X	
X	if (*pattern == 0) {
X	    if (*string == 0) {
X		return 1;
X	    } else {
X		return 0;
X	    }
X	}
X	if ((*string == 0) && (*pattern != '*')) {
X	    return 0;
X	}
X
X	/* Check for a "*" as the next pattern character.  It matches
X	 * any substring.  We handle this by calling ourselves
X	 * recursively for each postfix of string, until either we
X	 * match or we reach the end of the string.
X	 */
X	
X	if (*pattern == '*') {
X	    pattern += 1;
X	    if (*pattern == 0) {
X		return 1;
X	    }
X	    while (*string != 0) {
X		if (Tcl_StringMatch(string, pattern)) {
X		    return 1;
X		}
X		string += 1;
X	    }
X	    return 0;
X	}
X    
X	/* Check for a "?" as the next pattern character.  It matches
X	 * any single character.
X	 */
X
X	if (*pattern == '?') {
X	    goto thisCharOK;
X	}
X
X	/* Check for a "[" as the next pattern character.  It is followed
X	 * by a list of characters that are acceptable, or by a range
X	 * (two characters separated by "-").
X	 */
X	
X	if (*pattern == '[') {
X	    pattern += 1;
X	    while (1) {
X		if ((*pattern == ']') || (*pattern == 0)) {
X		    return 0;
X		}
X		if (*pattern == *string) {
X		    break;
X		}
X		if (pattern[1] == '-') {
X		    c2 = pattern[2];
X		    if (c2 == 0) {
X			return 0;
X		    }
X		    if ((*pattern <= *string) && (c2 >= *string)) {
X			break;
X		    }
X		    if ((*pattern >= *string) && (c2 <= *string)) {
X			break;
X		    }
X		    pattern += 2;
X		}
X		pattern += 1;
X	    }
X	    while ((*pattern != ']') && (*pattern != 0)) {
X		pattern += 1;
X	    }
X	    goto thisCharOK;
X	}
X    
X	/* If the next pattern character is '/', just strip off the '/'
X	 * so we do exact matching on the character that follows.
X	 */
X	
X	if (*pattern == '\\') {
X	    pattern += 1;
X	    if (*pattern == 0) {
X		return 0;
X	    }
X	}
X
X	/* There's no special character.  Just make sure that the next
X	 * characters of each string match.
X	 */
X	
X	if (*pattern != *string) {
X	    return 0;
X	}
X
X	thisCharOK: pattern += 1;
X	string += 1;
X    }
X}
END_OF_FILE
if test 21835 -ne `wc -c <'tclUtil.c'`; then
    echo shar: \"'tclUtil.c'\" unpacked with wrong size!
fi
# end of 'tclUtil.c'
fi
echo shar: End of archive 3 \(of 6\).
cp /dev/null ark3isdone
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


