Google Groups no longer supports new Usenet posts or subscriptions. Historical content remains viewable.

Dismiss

v25i069: tcl - tool command language, version 6.1, Part01/33

26 views

Skip to first unread message

Karl Lehenbauer

unread,

Nov 14, 1991, 3:25:03 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 69
Archive-name: tcl/part01
Environment: UNIX

This is a posting of the source and documentation for Tcl, an
embeddable tool command language, created by John Ousterhout.

This was posted at John's request by Karl Lehenbauer (ka...@NeoSoft.com).

This is release 6.1.

For more information, see the file "tcl6.1/README" in this release.

The file tclVar.c had to be split into two files, tclVar.c.1 and tclVar.c.2,
in order to not exceed the maximum size of a Usenet posting. Similarly,
the file doc/Tcl.man was split into three files, doc/Tcl.man.1, doc/Tcl.man.2
and doc/Tcl.man.3. Although these files should be automatically concatenated
when you unpack the last part, if they are not for some reason, you should put
them together by hand.

Good luck. If you have any problems with the Usenet distribution, contact
Karl or Mark Diekhans (ma...@Grizzly.com). For problems with Tcl 6.1 itself,
contact John Ousterhout (ous...@sprite.berkeley.edu).

Regards,
Karl Lehenbauer (ka...@NeoSoft.com)
-----------
#! /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 1 (of 33)."
# Contents: README tcl6.1 tcl6.1/MANIFEST tcl6.1/Makefile
# tcl6.1/compat tcl6.1/compat/README tcl6.1/compat/dirent.h
# tcl6.1/compat/dirent2.h tcl6.1/compat/limits.h
# tcl6.1/compat/opendir.c tcl6.1/compat/stdlib.h
# tcl6.1/compat/string.h tcl6.1/compat/strstr.c
# tcl6.1/compat/testpid.c tcl6.1/compat/testwait.c tcl6.1/doc
# tcl6.1/library tcl6.1/library/mkindex.tcl
# tcl6.1/library/parray.tcl tcl6.1/library/tclIndex tcl6.1/panic.c
# tcl6.1/regexp.h tcl6.1/tests tcl6.1/tests/all
# tcl6.1/tests/concat.test tcl6.1/tests/defs tcl6.1/tests/eval.test
# tcl6.1/tests/join.test tcl6.1/tests/llength.test
# tcl6.1/tests/lsearch.test tcl6.1/tests/lsort.test
# tcl6.1/tests/split.test tcl6.1/tests/unknown.test
# Wrapped by karl@one on Tue Nov 12 19:44:10 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'README'\"
else
echo shar: Extracting \"'README'\" $955 characters$
sed "s/^X//" >'README' <<'END_OF_FILE'
X
XThis is a posting of the source and documentation for Tcl, an
Xembeddable tool command language, created by John Ousterhout.
X
XThis is release 6.1.
X
XFor more information, see the file "tcl6.1/README" in this release.
X
XThis was posted at John's request by Karl Lehenbauer (ka...@NeoSoft.com).
X
XThe file tclVar.c had to be split into two files, tclVar.c.1 and tclVar.c.2,
Xin order to not exceed the maximum size of a Usenet posting. Similarly,
Xthe file doc/Tcl.man was split into three files, doc/Tcl.man.1, doc/Tcl.man.2
Xand doc/Tcl.man.3. Although these files should be automatically concatenated
Xwhen you unpack the last part, if they are not for some reason, you should put
Xthem together by hand.
X
XGood luck. If you have any problems with the Usenet distribution, contact
XKarl or Mark Diekhans (ma...@Grizzly.com). For problems with Tcl 6.1 itself,
Xcontact John Ousterhout (ous...@sprite.berkeley.edu).
X
XRegards,
XKarl Lehenbauer (ka...@NeoSoft.com)
X
END_OF_FILE
if test 955 -ne `wc -c <'README'`; then
echo shar: \"'README'\" unpacked with wrong size!
fi
# end of 'README'
fi
if test ! -d 'tcl6.1' ; then
echo shar: Creating directory \"'tcl6.1'\"
mkdir 'tcl6.1'
fi
if test -f 'tcl6.1/MANIFEST' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/MANIFEST'\"
else
echo shar: Extracting \"'tcl6.1/MANIFEST'\" $4022 characters$
sed "s/^X//" >'tcl6.1/MANIFEST' <<'END_OF_FILE'
X File Name Archive # Description
X-----------------------------------------------------------
X README 1
X tcl6.1 1
X tcl6.1/MANIFEST 1 This shipping list
X tcl6.1/Makefile 1
X tcl6.1/README 8
X tcl6.1/changes 11
X tcl6.1/compat 1
X tcl6.1/compat/README 1
X tcl6.1/compat/dirent.h 1
X tcl6.1/compat/dirent2.h 1
X tcl6.1/compat/limits.h 1
X tcl6.1/compat/opendir.c 1
X tcl6.1/compat/stdlib.h 1
X tcl6.1/compat/strerror.c 10
X tcl6.1/compat/string.h 1
X tcl6.1/compat/strstr.c 1
X tcl6.1/compat/strtol.c 2
X tcl6.1/compat/strtoul.c 3
X tcl6.1/compat/testpid.c 1
X tcl6.1/compat/testwait.c 1
X tcl6.1/config 7
X tcl6.1/doc 1
X tcl6.1/doc/AddErrInfo.man 6
X tcl6.1/doc/AssembCmd.man 5
X tcl6.1/doc/Backslash.man 4
X tcl6.1/doc/Concat.man 4
X tcl6.1/doc/CrtCommand.man 6
X tcl6.1/doc/CrtInterp.man 4
X tcl6.1/doc/CrtPipelin.man 5
X tcl6.1/doc/CrtTrace.man 6
X tcl6.1/doc/Eval.man 5
X tcl6.1/doc/ExprLong.man 5
X tcl6.1/doc/Fork.man 6
X tcl6.1/doc/GetInt.man 5
X tcl6.1/doc/Hash.man 10
X tcl6.1/doc/History.man 4
X tcl6.1/doc/Interp.man 7
X tcl6.1/doc/SetResult.man 8
X tcl6.1/doc/SetVar.man 8
X tcl6.1/doc/SplitList.man 6
X tcl6.1/doc/StrMatch.man 3
X tcl6.1/doc/Tcl.man.1 27
X tcl6.1/doc/Tcl.man.2 33
X tcl6.1/doc/Tcl.man.3 32
X tcl6.1/doc/TildeSubst.man 4
X tcl6.1/doc/TraceVar.man 14
X tcl6.1/doc/library.man 9
X tcl6.1/doc/usenix.text 31
X tcl6.1/library 1
X tcl6.1/library/init.tcl 3
X tcl6.1/library/mkindex.tcl 1
X tcl6.1/library/parray.tcl 1
X tcl6.1/library/tclIndex 1
X tcl6.1/panic.c 1
X tcl6.1/regexp.c 18
X tcl6.1/regexp.h 1
X tcl6.1/tcl.h 9
X tcl6.1/tclAssem.c 4
X tcl6.1/tclBasic.c 17
X tcl6.1/tclCkalloc.c 12
X tcl6.1/tclCmdAH.c 16
X tcl6.1/tclCmdIL.c 20
X tcl6.1/tclCmdMZ.c 28
X tcl6.1/tclEnv.c 9
X tcl6.1/tclExpr.c 26
X tcl6.1/tclGet.c 3
X tcl6.1/tclGlob.c 11
X tcl6.1/tclHash.c 16
X tcl6.1/tclHash.h 3
X tcl6.1/tclHistory.c 21
X tcl6.1/tclInt.h 23
X tcl6.1/tclParse.c 24
X tcl6.1/tclProc.c 12
X tcl6.1/tclTest.c 2
X tcl6.1/tclUnix.h 5
X tcl6.1/tclUnixAZ.c 30
X tcl6.1/tclUnixStr.c 12
X tcl6.1/tclUnixUtil.c 19
X tcl6.1/tclUtil.c 29
X tcl6.1/tclVar.c.1 25
X tcl6.1/tclVar.c.2 22
X tcl6.1/tests 1
X tcl6.1/tests/README 3
X tcl6.1/tests/all 1
X tcl6.1/tests/append.test 2
X tcl6.1/tests/case.test 2
X tcl6.1/tests/cd.test 2
X tcl6.1/tests/concat.test 1
X tcl6.1/tests/defs 1
X tcl6.1/tests/env.test 2
X tcl6.1/tests/error.test 3
X tcl6.1/tests/eval.test 1
X tcl6.1/tests/exec.test 4
X tcl6.1/tests/expr.test 14
X tcl6.1/tests/file.test 7
X tcl6.1/tests/for.test 3
X tcl6.1/tests/format.test 10
X tcl6.1/tests/glob.test 3
X tcl6.1/tests/history.test 11
X tcl6.1/tests/if.test 3
X tcl6.1/tests/incr.test 2
X tcl6.1/tests/info.test 9
X tcl6.1/tests/join.test 1
X tcl6.1/tests/lindex.test 2
X tcl6.1/tests/linsert.test 2
X tcl6.1/tests/list.test 2
X tcl6.1/tests/llength.test 1
X tcl6.1/tests/lrange.test 2
X tcl6.1/tests/lreplace.test 2
X tcl6.1/tests/lsearch.test 1
X tcl6.1/tests/lsort.test 1
X tcl6.1/tests/open.test 13
X tcl6.1/tests/parse.test 10
X tcl6.1/tests/proc.test 7
X tcl6.1/tests/regexp.test 7
X tcl6.1/tests/rename.test 2
X tcl6.1/tests/scan.test 15
X tcl6.1/tests/set.test 13
X tcl6.1/tests/source.test 2
X tcl6.1/tests/split.test 1
X tcl6.1/tests/string.test 8
X tcl6.1/tests/trace.test 15
X tcl6.1/tests/unknown.test 1
X tcl6.1/tests/uplevel.test 2
X tcl6.1/tests/upvar.test 4
X tcl6.1/tests/while.test 2
END_OF_FILE
if test 4022 -ne `wc -c <'tcl6.1/MANIFEST'`; then
echo shar: \"'tcl6.1/MANIFEST'\" unpacked with wrong size!
fi
# end of 'tcl6.1/MANIFEST'
fi
if test -f 'tcl6.1/Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/Makefile'\"
else
echo shar: Extracting \"'tcl6.1/Makefile'\" $1820 characters$
sed "s/^X//" >'tcl6.1/Makefile' <<'END_OF_FILE'
X#
X# This Makefile is for use when distributing Tcl to the outside world.
X# It is normally set up by running the "config" script. Before modifying
X# this file by hand, you should read through the "config" script to see
X# what it does.
X#
X# Some changes you may wish to make here:
X#
X# 1. To compile for non-UNIX systems (so that only the non-UNIX-specific
X# commands are available), change the OBJS line below so it doesn't
X# include ${UNIX_OBJS}. Also, add the switch "-DTCL_GENERIC_ONLY" to
X# CFLAGS. Lastly, you'll have to provide your own replacement for the
X# "panic" procedure (see panic.c for what the current one does).
X#
X# 2. ANSI-C procedure prototypes are turned on by default if supported
X# by the compiler. To turn them off, add "-DNO_PROTOTYPE" to CFLAGS
X# below.
X#
X# 3. If you've put the Tcl script library in a non-standard place, change
X# the definition of TCL_LIBRARY to correspond to its location on your
X# system.
X#
X
XTCL_LIBRARY = /usr/local/lib/tcl
X
XCC = cc
XCFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\"
X
XGENERIC_OBJS = regexp.o tclAssem.o tclBasic.o tclCkalloc.o \
X tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \
X tclHash.o tclHistory.o tclParse.o tclProc.o tclUtil.o \
X tclVar.o
X
XUNIX_OBJS = panic.o tclEnv.o tclGlob.o tclUnixAZ.o tclUnixStr.o \
X tclUnixUtil.o
X
XCOMPAT_OBJS = strerror.o opendir.o strstr.o strtoul.o
X
XOBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS}
X
Xlibtcl.a: ${OBJS}
X rm -f libtcl.a
X ar cr libtcl.a ${OBJS}
X
XtclTest: tclTest.o libtcl.a
X ${CC} ${CFLAGS} tclTest.o libtcl.a -o tclTest
X
Xclean:
X rm -f ${OBJS} libtcl.a tclTest.o tclTest
X
X# The following target is used during configuration to compile
X# a test program to see if certain facilities are available on
X# the system.
X
Xtest:
X ${CC} ${CFLAGS} test.c
X
X${OBJS}: tcl.h tclHash.h tclInt.h
X${UNIX_OBJS}: tclUnix.h
END_OF_FILE
if test 1820 -ne `wc -c <'tcl6.1/Makefile'`; then
echo shar: \"'tcl6.1/Makefile'\" unpacked with wrong size!
fi
# end of 'tcl6.1/Makefile'
fi
if test ! -d 'tcl6.1/compat' ; then
echo shar: Creating directory \"'tcl6.1/compat'\"
mkdir 'tcl6.1/compat'
fi
if test -f 'tcl6.1/compat/README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/README'\"
else
echo shar: Extracting \"'tcl6.1/compat/README'\" $363 characters$
sed "s/^X//" >'tcl6.1/compat/README' <<'END_OF_FILE'
XThis directory contains various header and code files that are
Xused make Tcl compatible with various releases of UNIX and UNIX-like
Xsystems. Typically, files from this directory are used to compile
XTcl when the corresponding files aren't present in the system's
Xlibrary area. When the whole world is POSIX-ified, this information
Xshould become unnecessary. (?)
END_OF_FILE
if test 363 -ne `wc -c <'tcl6.1/compat/README'`; then
echo shar: \"'tcl6.1/compat/README'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/README'
fi
if test -f 'tcl6.1/compat/dirent.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/dirent.h'\"
else
echo shar: Extracting \"'tcl6.1/compat/dirent.h'\" $809 characters$
sed "s/^X//" >'tcl6.1/compat/dirent.h' <<'END_OF_FILE'
X/*
X * dirent.h --
X *
X * This file is a replacement for <dirent.h> in systems that
X * support the old BSD-style <sys/dir.h> with a "struct direct".
X *
X * Copyright 1991 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 this copyright
X * notice appears 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 * $Header: /sprite/src/lib/tcl/compat/RCS/dirent.h,v 1.1 91/09/19 16:22:06 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _DIRENT
X#define _DIRENT
X
X#include <sys/dir.h>
X
X#define dirent direct
X
X#endif /* _DIRENT */
END_OF_FILE
if test 809 -ne `wc -c <'tcl6.1/compat/dirent.h'`; then
echo shar: \"'tcl6.1/compat/dirent.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/dirent.h'
fi
if test -f 'tcl6.1/compat/dirent2.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/dirent2.h'\"
else
echo shar: Extracting \"'tcl6.1/compat/dirent2.h'\" $1658 characters$
sed "s/^X//" >'tcl6.1/compat/dirent2.h' <<'END_OF_FILE'
X/*
X * dirent.h --
X *
X * Declarations of a library of directory-reading procedures
X * in the POSIX style ("struct dirent").
X *
X * Copyright 1991 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 this copyright
X * notice appears 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 * $Header: /sprite/src/lib/tcl/compat/RCS/dirent2.h,v 1.1 91/09/19 16:22:08 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _DIRENT
X#define _DIRENT
X
X#ifndef _TCL
X#include <tcl.h>
X#endif
X
X/*
X * Dirent structure, which holds information about a single
X * directory entry.
X */
X
X#define MAXNAMLEN 255
X#define DIRBLKSIZ 512
X
Xstruct dirent {
X long d_ino; /* Inode number of entry */
X short d_reclen; /* Length of this record */
X short d_namlen; /* Length of string in d_name */
X char d_name[MAXNAMLEN + 1]; /* Name must be no longer than this */
X};
X
X/*
X * State that keeps track of the reading of a directory (clients
X * should never look inside this structure; the fields should
X * only be accessed by the library procedures).
X */
X
Xtypedef struct _dirdesc {
X int dd_fd;
X long dd_loc;
X long dd_size;
X char dd_buf[DIRBLKSIZ];
X} DIR;
X
X/*
X * Procedures defined for reading directories:
X */
X
Xextern void closedir _ANSI_ARGS_((DIR *dirp));
Xextern DIR * opendir _ANSI_ARGS_((char *name));
Xextern struct dirent * readdir _ANSI_ARGS_((DIR *dirp));
X
X#endif /* _DIRENT */
END_OF_FILE
if test 1658 -ne `wc -c <'tcl6.1/compat/dirent2.h'`; then
echo shar: \"'tcl6.1/compat/dirent2.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/dirent2.h'
fi
if test -f 'tcl6.1/compat/limits.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/limits.h'\"
else
echo shar: Extracting \"'tcl6.1/compat/limits.h'\" $893 characters$
sed "s/^X//" >'tcl6.1/compat/limits.h' <<'END_OF_FILE'
X/*
X * limits.h --
X *
X * This is a dummy header file to #include in Tcl when there
X * is no limits.h in /usr/include. The file is totally empty.
X * In case you're wondering why Tcl includes the file at all
X * if it can be empty, it's because there's already code in
X * tclUnix.h to #define anything that's not defined in limits.h.
X *
X * Copyright 1991 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 this copyright
X * notice appears 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 * $Header: /sprite/src/lib/tcl/compat/RCS/limits.h,v 1.1 91/09/19 16:22:08 ouster Exp $ SPRITE (Berkeley)
X */
END_OF_FILE
if test 893 -ne `wc -c <'tcl6.1/compat/limits.h'`; then
echo shar: \"'tcl6.1/compat/limits.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/limits.h'
fi
if test -f 'tcl6.1/compat/opendir.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/opendir.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/opendir.c'\" $1983 characters$
sed "s/^X//" >'tcl6.1/compat/opendir.c' <<'END_OF_FILE'
X/*
X * opendir.c --
X *
X * This file provides dirent-style directory-reading procedures
X * for V7 Unix systems that don't have such procedures. The
X * origin of this code is unclear, but it seems to have come
X * originally from Larry Wall.
X *
X */
X
X#include <tclInt.h>
X#include <tclUnix.h>
X
X#undef DIRSIZ
X#define DIRSIZ(dp) \
X ((sizeof (struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3))
X
X/*
X * open a directory.
X */
XDIR *
Xopendir(name)
Xchar *name;
X{
X register DIR *dirp;
X register int fd;
X char *myname;
X
X myname = ((*name == '\0') ? "." : name);
X if ((fd = open(myname, 0, 0)) == -1)
X return NULL;
X if ((dirp = (DIR *)ckalloc(sizeof(DIR))) == NULL) {
X close (fd);
X return NULL;
X }
X dirp->dd_fd = fd;
X dirp->dd_loc = 0;
X return dirp;
X}
X
X/*
X * read an old style directory entry and present it as a new one
X */
X#ifndef pyr
X#define ODIRSIZ 14
X
Xstruct olddirect {
X ino_t od_ino;
X char od_name[ODIRSIZ];
X};
X#else /* a Pyramid in the ATT universe */
X#define ODIRSIZ 248
X
Xstruct olddirect {
X long od_ino;
X short od_fill1, od_fill2;
X char od_name[ODIRSIZ];
X};
X#endif
X
X/*
X * get next entry in a directory.
X */
Xstruct dirent *
Xreaddir(dirp)
Xregister DIR *dirp;
X{
X register struct olddirect *dp;
X static struct dirent dir;
X
X for (;;) {
X if (dirp->dd_loc == 0) {
X dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf,
X DIRBLKSIZ);
X if (dirp->dd_size <= 0)
X return NULL;
X }
X if (dirp->dd_loc >= dirp->dd_size) {
X dirp->dd_loc = 0;
X continue;
X }
X dp = (struct olddirect *)(dirp->dd_buf + dirp->dd_loc);
X dirp->dd_loc += sizeof(struct olddirect);
X if (dp->od_ino == 0)
X continue;
X dir.d_ino = dp->od_ino;
X strncpy(dir.d_name, dp->od_name, ODIRSIZ);
X dir.d_name[ODIRSIZ] = '\0'; /* insure null termination */
X dir.d_namlen = strlen(dir.d_name);
X dir.d_reclen = DIRSIZ(&dir);
X return (&dir);
X }
X}
X
X/*
X * close a directory.
X */
Xvoid
Xclosedir(dirp)
Xregister DIR *dirp;
X{
X close(dirp->dd_fd);
X dirp->dd_fd = -1;
X dirp->dd_loc = 0;
X ckfree((char *) dirp);
X}
END_OF_FILE
if test 1983 -ne `wc -c <'tcl6.1/compat/opendir.c'`; then
echo shar: \"'tcl6.1/compat/opendir.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/opendir.c'
fi
if test -f 'tcl6.1/compat/stdlib.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/stdlib.h'\"
else
echo shar: Extracting \"'tcl6.1/compat/stdlib.h'\" $1915 characters$
sed "s/^X//" >'tcl6.1/compat/stdlib.h' <<'END_OF_FILE'
X/*
X * stdlib.h --
X *
X * Declares facilities exported by the "stdlib" portion of
X * the C library. This file isn't complete in the ANSI-C
X * sense; it only declares things that are needed by Tcl.
X * This file is needed even on many systems with their own
X * stdlib.h (e.g. SunOS) because not all stdlib.h files
X * declare all the procedures needed here (such as strtod).
X *
X * Copyright 1991 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 appears 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 * $Header: /user6/ouster/tcl/compat/RCS/stdlib.h,v 1.2 91/10/17 10:52:12 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _STDLIB
X#define _STDLIB
X
X#include <tcl.h>
X
Xextern void abort _ANSI_ARGS_((void));
Xextern double atof _ANSI_ARGS_((char *string));
Xextern int atoi _ANSI_ARGS_((char *string));
Xextern long atol _ANSI_ARGS_((char *string));
Xextern char * calloc _ANSI_ARGS_((unsigned int numElements,
X unsigned int size));
Xextern int exit _ANSI_ARGS_((int status));
Xextern int free _ANSI_ARGS_((char *blockPtr));
Xextern char * getenv _ANSI_ARGS_((char *name));
Xextern char * malloc _ANSI_ARGS_((unsigned int numBytes));
Xextern void qsort _ANSI_ARGS_((char *base, int n, int size,
X int (*compar)(char *element1, char *element2)));
Xextern char * realloc _ANSI_ARGS_((char *ptr, unsigned int numBytes));
Xextern double strtod _ANSI_ARGS_((char *string, char **endPtr));
Xextern long strtol _ANSI_ARGS_((char *string, char **endPtr,
X int base));
Xextern unsigned long strtoul _ANSI_ARGS_((CONST char *string,
X char **endPtr, int base));
X
X#endif /* _STDLIB */
END_OF_FILE
if test 1915 -ne `wc -c <'tcl6.1/compat/stdlib.h'`; then
echo shar: \"'tcl6.1/compat/stdlib.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/stdlib.h'
fi
if test -f 'tcl6.1/compat/string.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/string.h'\"
else
echo shar: Extracting \"'tcl6.1/compat/string.h'\" $2141 characters$
sed "s/^X//" >'tcl6.1/compat/string.h' <<'END_OF_FILE'
X/*
X * string.h --
X *
X * Declarations of ANSI C library procedures for string handling.
X *
X * Copyright 1991 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 appears 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 * $Header: /sprite/src/lib/tcl/compat/RCS/string.h,v 1.1 91/09/19 16:22:11 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _STRING
X#define _STRING
X
X#include <tcl.h>
X
Xextern char * memchr _ANSI_ARGS_((char *s, int c, int n));
Xextern int memcmp _ANSI_ARGS_((char *s1, char *s2, int n));
Xextern char * memcpy _ANSI_ARGS_((char *t, char *f, int n));
Xextern char * memmove _ANSI_ARGS_((char *t, char *f, int n));
Xextern char * memset _ANSI_ARGS_((char *s, int c, int n));
X
Xextern int strcasecmp _ANSI_ARGS_((char *s1, char *s2));
Xextern char * strcat _ANSI_ARGS_((char *dst, char *src));
Xextern char * strchr _ANSI_ARGS_((char *string, int c));
Xextern int strcmp _ANSI_ARGS_((char *s1, char *s2));
Xextern char * strcpy _ANSI_ARGS_((char *dst, char *src));
Xextern int strcspn _ANSI_ARGS_((char *string, char *chars));
Xextern char * strdup _ANSI_ARGS_((char *string));
Xextern char * strerror _ANSI_ARGS_((int error));
Xextern int strlen _ANSI_ARGS_((char *string));
Xextern int strncasecmp _ANSI_ARGS_((char *s1, char *s2, int n));
Xextern char * strncat _ANSI_ARGS_((char *dst, char *src,
X int numChars));
Xextern int strncmp _ANSI_ARGS_((char *s1, char *s2, int nChars));
Xextern char * strncpy _ANSI_ARGS_((char *dst, char *src,
X int numChars));
Xextern char * strpbrk _ANSI_ARGS_((char *string, char *chars));
Xextern char * strrchr _ANSI_ARGS_((char *string, int c));
Xextern int strspn _ANSI_ARGS_((char *string, char *chars));
Xextern char * strstr _ANSI_ARGS_((char *string, char *substring));
Xextern char * strtok _ANSI_ARGS_((char *s, char *delim));
X
X#endif /* _STRING */
END_OF_FILE
if test 2141 -ne `wc -c <'tcl6.1/compat/string.h'`; then
echo shar: \"'tcl6.1/compat/string.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/string.h'
fi
if test -f 'tcl6.1/compat/strstr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/strstr.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/strstr.c'\" $1922 characters$
sed "s/^X//" >'tcl6.1/compat/strstr.c' <<'END_OF_FILE'
X/*
X * strstr.c --
X *
X * Source code for the "strstr" library routine.
X *
X * Copyright 1988-1991 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 appears 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/compat/RCS/strstr.c,v 1.1 91/09/19 16:22:12 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X/*
X *----------------------------------------------------------------------
X *
X * strstr --
X *
X * Locate the first instance of a substring in a string.
X *
X * Results:
X * If string contains substring, the return value is the
X * location of the first matching instance of substring
X * in string. If string doesn't contain substring, the
X * return value is 0. Matching is done on an exact
X * character-for-character basis with no wildcards or special
X * characters.
X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
Xstrstr(string, substring)
X register char *string; /* String to search. */
X char *substring; /* Substring to try to find in string. */
X{
X register char *a, *b;
X
X /* First scan quickly through the two strings looking for a
X * single-character match. When it's found, then compare the
X * rest of the substring.
X */
X
X b = substring;
X if (*b == 0) {
X return string;
X }
X for ( ; *string != 0; string += 1) {
X if (*string != *b) {
X continue;
X }
X a = string;
X while (1) {
X if (*b == 0) {
X return string;
X }
X if (*a++ != *b++) {
X break;
X }
X }
X b = substring;
X }
X return (char *) 0;
X}
END_OF_FILE
if test 1922 -ne `wc -c <'tcl6.1/compat/strstr.c'`; then
echo shar: \"'tcl6.1/compat/strstr.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/strstr.c'
fi
if test -f 'tcl6.1/compat/testpid.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/testpid.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/testpid.c'\" $931 characters$
sed "s/^X//" >'tcl6.1/compat/testpid.c' <<'END_OF_FILE'
X/*
X * testpid.c --
X *
X * This file contains a simple program that will compile
X * correctly if and only if <sys/types.h> defines the
X * type pid_t and uid_t. It is used to determine whether
X * these types are defined on a given system.
X *
X * Copyright 1991 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 this copyright
X * notice appears 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: /user6/ouster/tcl/compat/RCS/testpid.c,v 1.1 91/11/07 10:26:53 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <sys/types.h>
X
Xpid_t pid;
Xuid_t uid;
X
Xint main()
X{
X return 0;
X}
END_OF_FILE
if test 931 -ne `wc -c <'tcl6.1/compat/testpid.c'`; then
echo shar: \"'tcl6.1/compat/testpid.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/testpid.c'
fi
if test -f 'tcl6.1/compat/testwait.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/testwait.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/testwait.c'\" $946 characters$
sed "s/^X//" >'tcl6.1/compat/testwait.c' <<'END_OF_FILE'
X/*
X * testwait.c --
X *
X * This file contains a simple program that will compile
X * correctly if and only if <sys/wait.h> defines the
X * type "union wait". It is used during configuration
X * to determine whether or not to use this type.
X *
X * Copyright 1991 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 this copyright
X * notice appears 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: /user6/ouster/tcl/compat/RCS/testwait.c,v 1.1 91/11/07 10:26:56 ouster Exp $ SPRITE (Berkeley)";
X#endif /* not lint */
X
X#include <sys/types.h>
X#include <sys/wait.h>
X
Xunion wait x;
X
Xint main()
X{
X return 0;
X}
END_OF_FILE
if test 946 -ne `wc -c <'tcl6.1/compat/testwait.c'`; then
echo shar: \"'tcl6.1/compat/testwait.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/testwait.c'
fi
if test ! -d 'tcl6.1/doc' ; then
echo shar: Creating directory \"'tcl6.1/doc'\"
mkdir 'tcl6.1/doc'
fi
if test ! -d 'tcl6.1/library' ; then
echo shar: Creating directory \"'tcl6.1/library'\"
mkdir 'tcl6.1/library'
fi
if test -f 'tcl6.1/library/mkindex.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/library/mkindex.tcl'\"
else
echo shar: Extracting \"'tcl6.1/library/mkindex.tcl'\" $1662 characters$
sed "s/^X//" >'tcl6.1/library/mkindex.tcl' <<'END_OF_FILE'
X# auto_mkindex:
X# Given a directory and a glob-style specification for files in that
X# directory, generate a "tclIndex" file in the directory that is suitable
X# for use in auto-loading. Returns a null string.
X#
X# $Header: /sprite/src/lib/tcl/scripts/RCS/mkindex.tcl,v 1.1 91/09/26 09:55:03 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright 1991 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 this copyright
X# notice appears 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
Xproc auto_mkindex {dir files} {
X set oldDir [pwd]
X cd $dir
X set dir [pwd]
X append index "# Tcl autoload index file: each line identifies a Tcl\n"
X append index "# procedure and the file where that procedure is\n"
X append index "# defined. Generated by the \"auto_mkindex\" command.\n"
X append index "\n"
X foreach file [glob $files] {
X set f ""
X set error [catch {
X set f [open $file]
X while {[gets $f line] >= 0} {
X if [regexp {^proc[ ]+([^ ]*)} $line match indices] {
X set procName [string range $line [lindex $indices 0] \
X [lindex $indices 1]]
X append index "[list $procName $file]\n"
X }
X }
X close $f
X } msg]
X if $error {
X set code $errorCode
X set info $errorInfo
X catch [close $f]
X cd $oldDir
X error $msg $info $code
X }
X }
X set f [open tclIndex w]
X puts $f $index nonewline
X close $f
X cd $oldDir
X}
END_OF_FILE
if test 1662 -ne `wc -c <'tcl6.1/library/mkindex.tcl'`; then
echo shar: \"'tcl6.1/library/mkindex.tcl'\" unpacked with wrong size!
fi
# end of 'tcl6.1/library/mkindex.tcl'
fi
if test -f 'tcl6.1/library/parray.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/library/parray.tcl'\"
else
echo shar: Extracting \"'tcl6.1/library/parray.tcl'\" $1001 characters$
sed "s/^X//" >'tcl6.1/library/parray.tcl' <<'END_OF_FILE'
X# parray:
X# Print the contents of a global array on stdout.
X#
X# $Header: /sprite/src/lib/tcl/scripts/RCS/parray.tcl,v 1.1 91/09/26 09:55:03 ouster Exp $ SPRITE (Berkeley)
X#
X# Copyright 1991 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 this copyright
X# notice appears 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
Xproc parray a {
X global $a
X set maxl 0
X foreach name [lsort [array names $a]] {
X if {[string length $name] > $maxl} {
X set maxl [string length $name]
X }
X }
X set maxl [expr {$maxl + [string length $a] + 2}]
X foreach name [lsort [array names $a]] {
X set nameString [format %s(%s) $a $name]
X puts stdout [format "%-*s = %s" $maxl $nameString [set ${a}($name)]]
X }
X}
END_OF_FILE
if test 1001 -ne `wc -c <'tcl6.1/library/parray.tcl'`; then
echo shar: \"'tcl6.1/library/parray.tcl'\" unpacked with wrong size!
fi
# end of 'tcl6.1/library/parray.tcl'
fi
if test -f 'tcl6.1/library/tclIndex' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/library/tclIndex'\"
else
echo shar: Extracting \"'tcl6.1/library/tclIndex'\" $277 characters$
sed "s/^X//" >'tcl6.1/library/tclIndex' <<'END_OF_FILE'
X# Tcl autoload index file: each line identifies a Tcl
X# procedure and the file where that procedure is
X# defined. Generated by the "auto_mkindex" command.
X
Xunknown init.tcl
Xauto_load init.tcl
Xauto_execok init.tcl
Xauto_reset init.tcl
Xauto_mkindex mkindex.tcl
Xparray parray.tcl
END_OF_FILE
if test 277 -ne `wc -c <'tcl6.1/library/tclIndex'`; then
echo shar: \"'tcl6.1/library/tclIndex'\" unpacked with wrong size!
fi
# end of 'tcl6.1/library/tclIndex'
fi
if test -f 'tcl6.1/panic.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/panic.c'\"
else
echo shar: Extracting \"'tcl6.1/panic.c'\" $1603 characters$
sed "s/^X//" >'tcl6.1/panic.c' <<'END_OF_FILE'
X/*
X * panic.c --
X *
X * Source code for the "panic" library procedure for Tcl;
X * individual applications will probably override this with
X * an application-specific panic procedure.
X *
X * Copyright 1988-1991 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 appears 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: /user6/ouster/tcl/RCS/panic.c,v 1.3 91/10/10 11:25:51 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include <stdio.h>
X#include <stdlib.h>
X
X/*
X *----------------------------------------------------------------------
X *
X * panic --
X *
X * Print an error message and kill the process.
X *
X * Results:
X * None.
X *
X * Side effects:
X * The process dies, entering the debugger if possible.
X *
X *----------------------------------------------------------------------
X */
X
X /* VARARGS ARGSUSED */
Xvoid
Xpanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8)
X char *format; /* Format string, suitable for passing to
X * fprintf. */
X char *arg1, *arg2, *arg3; /* Additional arguments (variable in number)
X * to pass to fprintf. */
X char *arg4, *arg5, *arg6, *arg7, *arg8;
X{
X (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
X arg7, arg8);
X (void) fflush(stderr);
X abort();
X}
END_OF_FILE
if test 1603 -ne `wc -c <'tcl6.1/panic.c'`; then
echo shar: \"'tcl6.1/panic.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/panic.c'
fi
if test -f 'tcl6.1/regexp.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/regexp.h'\"
else
echo shar: Extracting \"'tcl6.1/regexp.h'\" $806 characters$
sed "s/^X//" >'tcl6.1/regexp.h' <<'END_OF_FILE'
X/*
X * Definitions etc. for regexp(3) routines.
X *
X * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
X * not the System V one.
X */
X
X#ifndef _TCL
X#include "tcl.h"
X#endif
X#ifndef _REGEXP
X#define _REGEXP 1
X
X#define NSUBEXP 10
Xtypedef struct regexp {
X char *startp[NSUBEXP];
X char *endp[NSUBEXP];
X char regstart; /* Internal use only. */
X char reganch; /* Internal use only. */
X char *regmust; /* Internal use only. */
X int regmlen; /* Internal use only. */
X char program[1]; /* Unwarranted chumminess with compiler. */
X} regexp;
X
Xextern regexp *regcomp _ANSI_ARGS_((char *exp));
Xextern int regexec _ANSI_ARGS_((regexp *prog, char *string));
Xextern void regsub _ANSI_ARGS_((regexp *prog, char *source, char *dest));
Xextern void regerror _ANSI_ARGS_((char *msg));
X
X#endif /* REGEXP */
END_OF_FILE
if test 806 -ne `wc -c <'tcl6.1/regexp.h'`; then
echo shar: \"'tcl6.1/regexp.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/regexp.h'
fi
if test ! -d 'tcl6.1/tests' ; then
echo shar: Creating directory \"'tcl6.1/tests'\"
mkdir 'tcl6.1/tests'
fi
if test -f 'tcl6.1/tests/all' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/all'\"
else
echo shar: Extracting \"'tcl6.1/tests/all'\" $315 characters$
sed "s/^X//" >'tcl6.1/tests/all' <<'END_OF_FILE'
X# This file contains a top-level script to run all of the Tcl
X# tests. Execute it by invoking "source all" when running tclTest
X# in this directory.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/all,v 1.4 91/09/08 13:43:07 ouster Exp $ (Berkeley)
X
Xforeach i [lsort [glob *.test]] {
X puts stdout $i
X source $i
X}
END_OF_FILE
if test 315 -ne `wc -c <'tcl6.1/tests/all'`; then
echo shar: \"'tcl6.1/tests/all'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/all'
fi
if test -f 'tcl6.1/tests/concat.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/concat.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/concat.test'\" $1604 characters$
sed "s/^X//" >'tcl6.1/tests/concat.test' <<'END_OF_FILE'
X# Commands covered: concat
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/concat.test,v 1.4 91/07/23 21:00:59 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest concat-1.1 {simple concatenation} {
X concat a b c d e f g
X} {a b c d e f g}
Xtest concat-1.2 {merging lists together} {
X concat a {b c d} {e f g h}
X} {a b c d e f g h}
Xtest concat-1.3 {merge lists, retain sub-lists} {
X concat a {b {c d}} {{e f}} g h
X} {a b {c d} {e f} g h}
Xtest concat-1.4 {special characters} {
X concat a\{ {b \{c d} \{d
X} "a{ b \\{c d {d"
X
Xtest concat-2.1 {error: no arguments} {catch concat} 1
Xtest concat-2.2 {error: no arguments} {
X catch concat msg
X set msg
X} {wrong # args: should be "concat arg ?arg ...?"}
X
Xtest concat-3.1 {pruning off extra white space} {
X concat {} {a b c}
X} {a b c}
Xtest concat-3.2 {pruning off extra white space} {
X concat x y " a b c \n\t " " " " def "
X} {x y a b c def}
END_OF_FILE
if test 1604 -ne `wc -c <'tcl6.1/tests/concat.test'`; then
echo shar: \"'tcl6.1/tests/concat.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/concat.test'
fi
if test -f 'tcl6.1/tests/defs' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/defs'\"
else
echo shar: Extracting \"'tcl6.1/tests/defs'\" $1884 characters$
sed "s/^X//" >'tcl6.1/tests/defs' <<'END_OF_FILE'
X# This file contains support code for the Tcl test suite. It is
X# normally sourced by the individual files in the test suite before
X# they run their tests. This improved approach to testing was designed
X# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
X
Xset VERBOSE 0
Xset TESTS {}
Xset auto_noexec 1
Xset auto_noload 1
Xcatch {rename unknown ""}
X
X# If tests are being run as root, issue a warning message and set a
X# variable to prevent some tests from running at all.
X
Xset user {}
Xcatch {set user [exec whoami]}
Xif {$user == "root"} {
X puts stdout "Warning: you're executing as root. I'll have to"
X puts stdout "skip some of the tests, since they'll fail as root."
X}
X
Xproc print_verbose {test_name test_description contents_of_test answer} {
X puts stdout "\n"
X puts stdout "==== $test_name $test_description"
X puts stdout "==== Contents of test case:"
X puts stdout "$contents_of_test"
X puts stdout "==== Result was:"
X puts stdout "$answer"
X}
X
Xproc test {test_name test_description contents_of_test passing_results} {
X global VERBOSE
X global TESTS
X if {[string compare $TESTS ""] != 0} then {
X set ok 0
X foreach test $TESTS {
X if [string match $test $test_name] then {
X set ok 1
X break
X }
X }
X if !$ok then return
X }
X set answer [uplevel $contents_of_test]
X if {[string compare $answer $passing_results] == 0} then {
X if $VERBOSE then {
X print_verbose $test_name $test_description $contents_of_test $answer
X puts stdout "++++ $test_name PASSED"
X }
X } else {
X print_verbose $test_name $test_description $contents_of_test $answer
X puts stdout "---- Result should have been:"
X puts stdout "$passing_results"
X puts stdout "---- $test_name FAILED"
X }
X}
X
Xproc dotests {file args} {
X global TESTS
X set savedTests $TESTS
X set TESTS $args
X source $file
X set TESTS $savedTests
X}
END_OF_FILE
if test 1884 -ne `wc -c <'tcl6.1/tests/defs'`; then
echo shar: \"'tcl6.1/tests/defs'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/defs'
fi
if test -f 'tcl6.1/tests/eval.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/eval.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/eval.test'\" $1765 characters$
sed "s/^X//" >'tcl6.1/tests/eval.test' <<'END_OF_FILE'
X# Commands covered: eval
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/eval.test,v 1.4 91/08/20 14:19:02 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest eval-1.1 {single argument} {
X eval {format 22}
X} 22
Xtest eval-1.2 {multiple arguments} {
X set a {$b}
X set b xyzzy
X eval format $a
X} xyzzy
Xtest eval-1.3 {single argument} {
X eval concat a b c d e f g
X} {a b c d e f g}
X
Xtest eval-2.1 {error: not enough arguments} {catch eval} 1
Xtest eval-2.2 {error: not enough arguments} {
X catch eval msg
X set msg
X} {wrong # args: should be "eval arg ?arg ...?"}
Xtest eval-2.3 {error in eval'ed command} {
X catch {eval {error "test error"}}
X} 1
Xtest eval-2.4 {error in eval'ed command} {
X catch {eval {error "test error"}} msg
X set msg
X} {test error}
Xtest eval-2.5 {error in eval'ed command: setting errorInfo} {
X catch {eval {
X set a 1
X error "test error"
X }} msg
X set errorInfo
X} "test error
X while executing
X\"error \"test error\"\"
X (\"eval\" body line 3)
X invoked from within
X\"eval {
X set a 1
X error \"test error\"
X }\""
END_OF_FILE
if test 1765 -ne `wc -c <'tcl6.1/tests/eval.test'`; then
echo shar: \"'tcl6.1/tests/eval.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/eval.test'
fi
if test -f 'tcl6.1/tests/join.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/join.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/join.test'\" $1519 characters$
sed "s/^X//" >'tcl6.1/tests/join.test' <<'END_OF_FILE'
X# Commands covered: join
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/join.test,v 1.3 91/08/01 17:19:57 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest join-1.1 {basic join commands} {
X join {a b c} xyz
X} axyzbxyzc
Xtest join-1.2 {basic join commands} {
X join {a b c} {}
X} abc
Xtest join-1.3 {basic join commands} {
X join {} xyz
X} {}
Xtest join-1.4 {basic join commands} {
X join {12 34 56}
X} {12 34 56}
X
Xtest join-2.1 {join errors} {
X list [catch join msg] $msg $errorCode
X} {1 {wrong # args: should be "join list ?joinString?"} NONE}
Xtest join-2.2 {join errors} {
X list [catch {join a b c} msg] $msg $errorCode
X} {1 {wrong # args: should be "join list ?joinString?"} NONE}
Xtest join-2.3 {join errors} {
X list [catch {join "a \{ c" 111} msg] $msg $errorCode
X} {1 {unmatched open brace in list} NONE}
END_OF_FILE
if test 1519 -ne `wc -c <'tcl6.1/tests/join.test'`; then
echo shar: \"'tcl6.1/tests/join.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/join.test'
fi
if test -f 'tcl6.1/tests/llength.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/llength.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/llength.test'\" $1416 characters$
sed "s/^X//" >'tcl6.1/tests/llength.test' <<'END_OF_FILE'
X# Commands covered: llength
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/llength.test,v 1.1 91/09/06 14:48:03 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest llength-1.1 {length of list} {
X llength {a b c d}
X} 4
Xtest llength-1.2 {length of list} {
X llength {a b c {a b {c d}} d}
X} 5
Xtest llength-1.3 {length of list} {
X llength {}
X} 0
X
Xtest llength-2.1 {error conditions} {
X list [catch {llength} msg] $msg
X} {1 {wrong # args: should be "llength list"}}
Xtest llength-2.2 {error conditions} {
X list [catch {llength 123 2} msg] $msg
X} {1 {wrong # args: should be "llength list"}}
Xtest llength-2.3 {error conditions} {
X list [catch {llength "a b c \{"} msg] $msg
X} {1 {unmatched open brace in list}}
END_OF_FILE
if test 1416 -ne `wc -c <'tcl6.1/tests/llength.test'`; then
echo shar: \"'tcl6.1/tests/llength.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/llength.test'
fi
if test -f 'tcl6.1/tests/lsearch.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/lsearch.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/lsearch.test'\" $1630 characters$
sed "s/^X//" >'tcl6.1/tests/lsearch.test' <<'END_OF_FILE'
X# Commands covered: lsearch
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/lsearch.test,v 1.1 91/08/21 13:37:25 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xset x {abcd bbcd 123 234 345}
Xtest lsearch-1.1 {lsearch command} {
X lsearch $x 123
X} 2
Xtest lsearch-1.2 {lsearch command} {
X lsearch $x 3456
X} -1
Xtest lsearch-1.3 {lsearch command} {
X lsearch $x *5
X} 4
Xtest lsearch-1.4 {lsearch command} {
X lsearch $x *bc*
X} 0
X
Xtest lsearch-2.1 {lsearch errors} {
X list [catch lsearch msg] $msg
X} {1 {wrong # args: should be "lsearch list pattern"}}
Xtest lsearch-2.2 {lsearch errors} {
X list [catch {lsearch a} msg] $msg
X} {1 {wrong # args: should be "lsearch list pattern"}}
Xtest lsearch-2.3 {lsearch errors} {
X list [catch {lsearch a b c} msg] $msg
X} {1 {wrong # args: should be "lsearch list pattern"}}
Xtest lsearch-2.4 {lsearch errors} {
X list [catch {lsearch "\{" b} msg] $msg
X} {1 {unmatched open brace in list}}
END_OF_FILE
if test 1630 -ne `wc -c <'tcl6.1/tests/lsearch.test'`; then
echo shar: \"'tcl6.1/tests/lsearch.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/lsearch.test'
fi
if test -f 'tcl6.1/tests/lsort.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/lsort.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/lsort.test'\" $1505 characters$
sed "s/^X//" >'tcl6.1/tests/lsort.test' <<'END_OF_FILE'
X# Commands covered: lsort
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/lsort.test,v 1.1 91/08/21 13:37:25 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest lsort-1.1 {lsort command} {
X lsort {abdeq ab 1 ac a}
X} {1 a ab abdeq ac}
Xtest lsort-1.2 {lsort command} {
X lsort {{one long element}}
X} {{one long element}}
Xtest lsort-1.3 {lsort command} {
X lsort {}
X} {}
Xtest lsort-1.4 {lsort with characters needing backslashes} {
X lsort {$ \\ [] \{}
X} {{$} {[]} \\ \{}
X
Xtest lsort-2.1 {lsort errors} {
X list [catch lsort msg] $msg
X} {1 {wrong # args: should be "lsort list"}}
Xtest lsort-2.2 {lsort errors} {
X list [catch {lsort a b} msg] $msg
X} {1 {wrong # args: should be "lsort list"}}
Xtest lsort-2.3 {lsort errors} {
X list [catch {lsort "\{"} msg] $msg
X} {1 {unmatched open brace in list}}
END_OF_FILE
if test 1505 -ne `wc -c <'tcl6.1/tests/lsort.test'`; then
echo shar: \"'tcl6.1/tests/lsort.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/lsort.test'
fi
if test -f 'tcl6.1/tests/split.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/split.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/split.test'\" $1701 characters$
sed "s/^X//" >'tcl6.1/tests/split.test' <<'END_OF_FILE'
X# Commands covered: split
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/split.test,v 1.2 91/08/11 17:08:26 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xtest split-1.1 {basic split commands} {
X split "a\n b\t\r c\n "
X} {a {} b {} {} c {} {}}
Xtest split-1.2 {basic split commands} {
X split "word 1xyzword 2zword 3" xyz
X} {{word 1} {} {} {word 2} {word 3}}
Xtest split-1.3 {basic split commands} {
X split "12345" {}
X} {1 2 3 4 5}
Xtest split-1.4 {basic split commands} {
X split "a\}b\[c\{\]\$"
X} "a}b\\\[c{\\\]\\\$"
Xtest split-1.5 {basic split commands} {
X split {} {}
X} {}
Xtest split-1.6 {basic split commands} {
X split {}
X} {}
Xtest split-1.7 {basic split commands} {
X split { }
X} {{} {} {} {}}
X
Xtest split-2.1 {split errors} {
X list [catch split msg] $msg $errorCode
X} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
Xtest split-2.2 {split errors} {
X list [catch {split a b c} msg] $msg $errorCode
X} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
END_OF_FILE
if test 1701 -ne `wc -c <'tcl6.1/tests/split.test'`; then
echo shar: \"'tcl6.1/tests/split.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/split.test'
fi
if test -f 'tcl6.1/tests/unknown.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/unknown.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/unknown.test'\" $1948 characters$
sed "s/^X//" >'tcl6.1/tests/unknown.test' <<'END_OF_FILE'
X# Commands covered: unknown
X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#
X# $Header: /sprite/src/lib/tcl/tests/RCS/unknown.test,v 1.3 91/08/21 13:53:23 ouster Exp $ (Berkeley)
X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X
Xcatch {rename unknown {}}
X
Xtest unknown-1.1 {non-existent "unknown" command} {
X list [catch {_non-existent_ foo bar} msg] $msg
X} {1 {invalid command name: "_non-existent_"}}
X
Xproc unknown {args} {
X global x
X set x $args
X}
X
Xtest unknown-2.1 {calling "unknown" command} {
X foobar x y z
X set x
X} {foobar x y z}
Xtest unknown-2.2 {calling "unknown" command with lots of args} {
X foobar 1 2 3 4 5 6 7
X set x
X} {foobar 1 2 3 4 5 6 7}
Xtest unknown-2.3 {calling "unknown" command with lots of args} {
X foobar 1 2 3 4 5 6 7 8
X set x
X} {foobar 1 2 3 4 5 6 7 8}
Xtest unknown-2.4 {calling "unknown" command with lots of args} {
X foobar 1 2 3 4 5 6 7 8 9
X set x
X} {foobar 1 2 3 4 5 6 7 8 9}
X
Xtest unknown-3.1 {argument quoting in calls to "unkown"} {
X foobar \{ \} a\{b \; "\\" \$a a\[b \]
X set x
X} "foobar \\{ \} a\{b {;} \\\\ {\$a} {a\[b} \\]"
X
Xproc unknown args {
X error "unknown failed"
X}
X
Xtest unknown-4.1 {errors in "unknown" procedure} {
X list [catch {non-existent a b} msg] $msg $errorCode
X} {1 {unknown failed} NONE}
X
Xcatch {rename unknown {}}
Xreturn {}
END_OF_FILE
if test 1948 -ne `wc -c <'tcl6.1/tests/unknown.test'`; then
echo shar: \"'tcl6.1/tests/unknown.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/unknown.test'
fi
echo shar: End of archive 1 $of 33$.
cp /dev/null ark1isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 33 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield INTERNET: ke...@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to ke...@uunet.uu.net.

Karl Lehenbauer

unread,

Nov 14, 1991, 3:25:36 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 70
Archive-name: tcl/part02
Environment: UNIX

#! /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 2 (of 33)."
# Contents: tcl6.1/compat/strtol.c tcl6.1/tclTest.c
# tcl6.1/tests/append.test tcl6.1/tests/case.test
# tcl6.1/tests/cd.test tcl6.1/tests/env.test tcl6.1/tests/incr.test
# tcl6.1/tests/lindex.test tcl6.1/tests/linsert.test
# tcl6.1/tests/list.test tcl6.1/tests/lrange.test
# tcl6.1/tests/lreplace.test tcl6.1/tests/rename.test
# tcl6.1/tests/source.test tcl6.1/tests/uplevel.test
# tcl6.1/tests/while.test
# Wrapped by karl@one on Tue Nov 12 19:44:11 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/compat/strtol.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/strtol.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/strtol.c'\" $2267 characters$
sed "s/^X//" >'tcl6.1/compat/strtol.c' <<'END_OF_FILE'
X/*
X * strtol.c --
X *
X * Source code for the "strtol" library procedure.
X *
X * Copyright 1988 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/compat/RCS/strtol.c,v 1.1 91/09/22 15:42:49 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include <ctype.h>
X

X
X/*
X *----------------------------------------------------------------------
X *

X * strtol --
X *
X * Convert an ASCII string into an integer.

X *
X * Results:

X * The return value is the integer equivalent of string. If endPtr
X * is non-NULL, then *endPtr is filled in with the character
X * after the last one that was part of the integer. If string
X * doesn't contain a valid integer value, then zero is returned
X * and *endPtr is set to string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xlong int
Xstrtol(string, endPtr, base)
X char *string; /* String of ASCII digits, possibly
X * preceded by white space. For bases
X * greater than 10, either lower- or
X * upper-case digits may be used.
X */
X char **endPtr; /* Where to store address of terminating
X * character, or NULL. */
X int base; /* Base for conversion. Must be less
X * than 37. If 0, then the base is chosen
X * from the leading characters of string:
X * "0x" means hex, "0" means octal, anything
X * else means decimal.
X */
X{
X register char *p;
X int result;
X
X /*
X * Skip any leading blanks.
X */
X
X p = string;
X while (isspace(*p)) {
X p += 1;
X }
X
X /*
X * Check for a sign.
X */
X
X if (*p == '-') {
X p += 1;
X result = -(strtoul(p, endPtr, base));
X } else {
X if (*p == '+') {
X p += 1;
X }
X result = strtoul(p, endPtr, base);
X }
X if ((result == 0) && (endPtr != 0) && (*endPtr == p)) {
X *endPtr = string;
X }
X return result;
X}
END_OF_FILE
if test 2267 -ne `wc -c <'tcl6.1/compat/strtol.c'`; then
echo shar: \"'tcl6.1/compat/strtol.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/strtol.c'
fi
if test -f 'tcl6.1/tclTest.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclTest.c'\"
else
echo shar: Extracting \"'tcl6.1/tclTest.c'\" $3427 characters$
sed "s/^X//" >'tcl6.1/tclTest.c' <<'END_OF_FILE'
X/*
X * tclTest.c --
X *
X * Test driver for TCL.
X *
X * Copyright 1987-1991 Regents of the University of California
X * All rights reserved.
X *

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 appears 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: /user6/ouster/tcl/tclTest/RCS/tclTest.c,v 1.18 91/10/27 16:46:07 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include <stdio.h>
X#include <errno.h>
X#include <string.h>
X#include "tcl.h"
X
Xextern int exit();
Xextern int Tcl_DumpActiveMemory();
X
XTcl_Interp *interp;
XTcl_CmdBuf buffer;
Xchar dumpFile[100];
Xint quitFlag = 0;
X
Xchar *initCmd =
X "if [file exists [info library]/init.tcl] {source [info library]/init.tcl}";
X
X /* ARGSUSED */
Xint
XcmdCheckmem(clientData, interp, argc, argv)
X ClientData *clientData;
X Tcl_Interp *interp;
X int argc;
X char *argv[];
X{
X if (argc != 2) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " fileName\"", (char *) NULL);
X return TCL_ERROR;
X }
X strcpy(dumpFile, argv[1]);
X quitFlag = 1;
X return TCL_OK;
X}
X
X /* ARGSUSED */
Xint
XcmdEcho(clientData, interp, argc, argv)
X ClientData *clientData;
X Tcl_Interp *interp;
X int argc;
X char *argv[];
X{
X int i;
X
X for (i = 1; ; i++) {
X if (argv[i] == NULL) {
X if (i != argc) {
X echoError:
X sprintf(interp->result,
X "argument list wasn't properly NULL-terminated in \"%s\" command",
X argv[0]);
X }
X break;
X }
X if (i >= argc) {
X goto echoError;
X }
X fputs(argv[i], stdout);
X if (i < (argc-1)) {
X printf(" ");
X }
X }
X printf("\n");
X return TCL_OK;
X}
X
Xvoid
XdeleteProc(clientData)
X char *clientData;
X{
X printf("Deleting command with clientData \"%s\".\n", clientData);
X}
X
Xint
Xmain()
X{
X char line[1000], *cmd;
X int result, gotPartial;
X
X interp = Tcl_CreateInterp();
X#ifdef TCL_MEM_DEBUG
X Tcl_InitMemory(interp);
X#endif
X Tcl_CreateCommand(interp, "echo", cmdEcho, (ClientData) "echo",
X (Tcl_CmdDeleteProc *) NULL);
X Tcl_CreateCommand(interp, "checkmem", cmdCheckmem, (ClientData) 0,
X (Tcl_CmdDeleteProc *) NULL);
X buffer = Tcl_CreateCmdBuf();
X result = Tcl_Eval(interp, initCmd, 0, (char **) NULL);
X if (result != TCL_OK) {
X printf("%s\n", interp->result);
X exit(1);
X }
X
X gotPartial = 0;
X while (1) {
X clearerr(stdin);
X if (!gotPartial) {
X fputs("% ", stdout);
X fflush(stdout);
X }
X if (fgets(line, 1000, stdin) == NULL) {
X if (!gotPartial) {
X exit(0);
X }
X line[0] = 0;
X }
X cmd = Tcl_AssembleCmd(buffer, line);
X if (cmd == NULL) {
X gotPartial = 1;
X continue;
X }
X
X gotPartial = 0;
X result = Tcl_RecordAndEval(interp, cmd, 0);
X if (result == TCL_OK) {
X if (*interp->result != 0) {
X printf("%s\n", interp->result);
X }
X if (quitFlag) {
X Tcl_DeleteInterp(interp);
X Tcl_DeleteCmdBuf(buffer);
X#ifdef TCL_MEM_DEBUG
X Tcl_DumpActiveMemory(dumpFile);
X#endif
X exit(0);
X }
X } else {
X if (result == TCL_ERROR) {
X printf("Error");
X } else {
X printf("Error %d", result);
X }
X if (*interp->result != 0) {
X printf(": %s\n", interp->result);
X } else {
X printf("\n");
X }
X }
X }
X}
END_OF_FILE
if test 3427 -ne `wc -c <'tcl6.1/tclTest.c'`; then
echo shar: \"'tcl6.1/tclTest.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclTest.c'
fi
if test -f 'tcl6.1/tests/append.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/append.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/append.test'\" $3126 characters$
sed "s/^X//" >'tcl6.1/tests/append.test' <<'END_OF_FILE'
X# Commands covered: append lappend

X#
X# This file contains a collection of tests for one or more of the Tcl
X# built-in commands. Sourcing this file into Tcl runs the tests and
X# generates output for errors. No output means no errors were found.
X#
X# Copyright 1991 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 this copyright notice
X# appears in all copies. The University of California makes no
X# representations about the suitability of this software for any
X# purpose. It is provided "as is" without express or implied
X# warranty.
X#

X# $Header: /sprite/src/lib/tcl/tests/RCS/append.test,v 1.3 91/09/08 13:43:32 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {unset x}
Xtest append-1.1 {append command} {
X catch {unset x}
X list [append x 1 2 abc "long string"] $x
X} {{12abclong string} {12abclong string}}
Xtest append-1.2 {append command} {
X set x ""
X list [append x first] [append x second] [append x third] $x
X} {first firstsecond firstsecondthird firstsecondthird}
X
Xtest append-2.1 {long appends} {
X set x ""
X for {set i 0} {$i < 1000} {set i [expr $i+1]} {
X append x "foobar "
X }
X set y "foobar"
X set y "$y $y $y $y $y $y $y $y $y $y"
X set y "$y $y $y $y $y $y $y $y $y $y"
X set y "$y $y $y $y $y $y $y $y $y $y "
X expr {$x == $y}
X} 1
X
Xtest append-3.1 {append errors} {
X list [catch {append} msg] $msg
X} {1 {wrong # args: should be "append varName value ?value ...?"}}
Xtest append-3.2 {append errors} {
X list [catch {append x} msg] $msg
X} {1 {wrong # args: should be "append varName value ?value ...?"}}
Xtest append-3.3 {append errors} {
X set x ""
X list [catch {append x(0) 44} msg] $msg
X} {1 {can't set "x(0)": variable isn't array}}
X
Xtest append-4.1 {lappend command} {
X catch {unset x}
X list [lappend x 1 2 abc "long string"] $x
X} {{1 2 abc {long string}} {1 2 abc {long string}}}
Xtest append-4.2 {lappend command} {
X set x ""
X list [lappend x first] [lappend x second] [lappend x third] $x
X} {first {first second} {first second third} {first second third}}
X
Xproc check {var size} {
X set l [llength $var]
X if {$l != $size} {
X return "length mismatch: should have been $size, was $l"
X }
X for {set i 0} {$i < $size} {set i [expr $i+1]} {
X set j [lindex $var $i]
X if {$j != "item $i"} {
X return "element $i should have been \"item $i\", was \"$j\"
X }
X }
X return ok
X}
Xtest append-5.1 {long lappends} {
X set x ""
X for {set i 0} {$i < 300} {set i [expr $i+1]} {
X lappend x "item $i"
X }
X check $x 300
X} ok
X
Xtest append-6.1 {lappend errors} {
X list [catch {lappend} msg] $msg
X} {1 {wrong # args: should be "lappend varName value ?value ...?"}}
Xtest append-6.2 {lappend errors} {
X list [catch {lappend x} msg] $msg
X} {1 {wrong # args: should be "lappend varName value ?value ...?"}}
Xtest append-6.3 {lappend errors} {
X set x ""
X list [catch {lappend x(0) 44} msg] $msg
X} {1 {can't set "x(0)": variable isn't array}}
END_OF_FILE
if test 3126 -ne `wc -c <'tcl6.1/tests/append.test'`; then
echo shar: \"'tcl6.1/tests/append.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/append.test'
fi
if test -f 'tcl6.1/tests/case.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/case.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/case.test'\" $2756 characters$
sed "s/^X//" >'tcl6.1/tests/case.test' <<'END_OF_FILE'
X# Commands covered: case

X# $Header: /user6/ouster/tcl/tests/RCS/case.test,v 1.5 91/11/07 09:01:50 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest case-1.1 {simple pattern} {
X case a in a {format 1} b {format 2} c {format 3} default {format 4}
X} 1
Xtest case-1.2 {simple pattern} {
X case b a {format 1} b {format 2} c {format 3} default {format 4}
X} 2
Xtest case-1.3 {simple pattern} {
X case x in a {format 1} b {format 2} c {format 3} default {format 4}
X} 4
Xtest case-1.4 {simple pattern} {
X case x a {format 1} b {format 2} c {format 3}
X} {}
Xtest case-1.5 {simple pattern matches many times} {
X case b a {format 1} b {format 2} b {format 3} b {format 4}
X} 2
Xtest case-1.6 {fancier pattern} {
X case cx a {format 1} *c {format 2} *x {format 3} default {format 4}
X} 3
Xtest case-1.7 {list of patterns} {
X case abc in {a b c} {format 1} {def abc ghi} {format 2}
X} 2
X
Xtest case-2.1 {error in executed command} {
X list [catch {case a in a {error "Just a test"} default {format 1}} msg] \
X $msg $errorInfo
X} {1 {Just a test} {Just a test
X while executing
X"error "Just a test""
X ("a" arm line 1)
X invoked from within
X"case a in a {error "Just a test"} default {format 1}"}}
Xtest case-2.2 {error: not enough args} {
X list [catch {case} msg] $msg
X} {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}}
Xtest case-2.3 {error: pattern with no body} {
X list [catch {case a b} msg] $msg
X} {1 {extra case pattern with no body}}
Xtest case-2.4 {error: pattern with no body} {
X list [catch {case a in b {format 1} c} msg] $msg
X} {1 {extra case pattern with no body}}
X
Xtest case-3.1 {single-argument form for pattern/command pairs} {
X case b in {
X a {format 1}
X b {format 2}
X default {format 6}
X }
X} {2}
Xtest case-3.2 {single-argument form for pattern/command pairs} {
X case b {
X a {format 1}
X b {format 2}
X default {format 6}
X }
X} {2}
Xtest case-3.3 {single-argument form for pattern/command pairs} {
X list [catch {case z in {a 2 b}} msg] $msg
X} {1 {extra case pattern with no body}}
END_OF_FILE
if test 2756 -ne `wc -c <'tcl6.1/tests/case.test'`; then
echo shar: \"'tcl6.1/tests/case.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/case.test'
fi
if test -f 'tcl6.1/tests/cd.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/cd.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/cd.test'\" $2888 characters$
sed "s/^X//" >'tcl6.1/tests/cd.test' <<'END_OF_FILE'
X# Commands covered: cd, pwd

X# $Header: /user6/ouster/tcl/tests/RCS/cd.test,v 1.15 91/10/17 16:22:35 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {exec rm -rf cd.dir}
Xexec mkdir cd.dir
Xexec cat << "Sample text" > cd.dir/test.file
Xset cwd [exec pwd]
X
Xtest cd-1.1 {simple pwd check} {
X pwd
X} $cwd
X
Xcd cd.dir
Xtest cd-2.1 {changing directories} {
X list [exec pwd]
X} $cwd/cd.dir
Xtest cd-2.2 {changing directories} {
X pwd
X} $cwd/cd.dir
Xtest cd-2.3 {changing directories} {
X exec cat test.file
X} "Sample text"
Xcd ..
Xtest cd-2.4 {changing directories} {
X exec pwd
X} $cwd
Xtest cd-2.5 {changing directories} {
X pwd
X} $cwd
Xtest cd-2.6 {changing directories} {
X exec cat cd.dir/test.file
X} "Sample text"
Xset home [exec sh -c "cd; pwd"]
Xtest cd-2.7 {changing directories} {
X cd ~
X set x [list [exec pwd] [pwd]]
X cd $cwd
X set x
X} "$home $home"
Xtest cd-2.8 {changing directories} {
X cd
X set x [list [exec pwd] [pwd]]
X cd $cwd
X set x
X} "$home $home"
X
Xtest cd-3.1 {cd return value} {
X cd .
X} {}
X
Xtest cd-4.1 {errors in cd command} {
X list [catch {cd 1 2} msg] $msg $errorCode
X} {1 {wrong # args: should be "cd dirName"} NONE}
Xtest cd-4.2 {errors in cd command} {
X string tolower [list [catch {cd _non_existent_dir} msg] $msg $errorCode]
X} {1 {couldn't change working directory to "_non_existent_dir": no such file or directory} \
X{unix enoent {no such file or directory}}}
Xtest cd-4.3 {errors in cd command} {
X string tolower [list [catch {cd cd.dir/test.file} msg] $msg $errorCode]
X} {1 {couldn't change working directory to "cd.dir/test.file": not a directory} {unix enotdir {not a directory}}}
Xtest cd-4.4 {errors in cd command} {
X set home $env(HOME)
X unset env(HOME)
X set x [list [catch cd msg] $msg]
X set env(HOME) $home
X set x
X} {1 {couldn't find HOME environment variable to expand "~"}}
X
Xtest cd-5.1 {errors in pwd command} {
X list [catch {pwd a} msg] $msg
X} {1 {wrong # args: should be "pwd"}}
Xexec mkdir cd.dir/child
Xcd cd.dir/child
Xexec chmod 111 ..
Xif {$user != "root"} {
X test cd-5.2 {errors in pwd command} {
X catch pwd msg
X } 1
X}
Xcd $cwd
Xexec chmod 775 cd.dir
X
Xcatch {exec rm -rf cd.dir}
Xformat ""
END_OF_FILE
if test 2888 -ne `wc -c <'tcl6.1/tests/cd.test'`; then
echo shar: \"'tcl6.1/tests/cd.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/cd.test'
fi
if test -f 'tcl6.1/tests/env.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/env.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/env.test'\" $2832 characters$
sed "s/^X//" >'tcl6.1/tests/env.test' <<'END_OF_FILE'
X# Commands covered: none (tests environment variable implementation)

X# $Header: /sprite/src/lib/tcl/tests/RCS/env.test,v 1.4 91/09/16 14:39:47 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# If there is no "printenv" program on this system, then it's just too
X# much trouble to run this test (can't necessarily run csh to get the
X# envionrment: on some systems it barfs if there isn't a minimum set
X# predefined environment variables. Also, printenv returns a non-zero
X# status on some systems, so read the environment using a procedure
X# that catches errors.
X
Xset printenv {}
Xif [info exists env(PATH)] {
X set dirs [split $env(PATH) :]
X} else {
X set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc}
X}
Xforeach i $dirs {
X if [file executable $i/printenv] {
X set printenv $i/printenv
X break
X }
X}
Xif {$printenv == ""} {
X puts stdout "Skipping env tests: need \"printenv\" to read environment."
X return ""
X}
Xproc getenv {} {
X global printenv
X catch {exec $printenv} out
X return $out
X}
X
X# Save the current environment variables at the start of the test.
X
Xforeach name [array names env] {
X set env2($name) $env($name)
X unset env($name)
X}
X
Xtest env-1.1 {adding environment variables} {
X getenv
X} {}
X
Xset env(NAME1) "test string"
Xtest env-1.2 {adding environment variables} {
X getenv
X} {NAME1=test string}
X
Xset env(NAME2) "more"
Xtest env-1.3 {adding environment variables} {
X getenv
X} {NAME1=test string
XNAME2=more}
X
Xset env(XYZZY) "garbage"
Xtest env-1.4 {adding environment variables} {
X getenv
X} {NAME1=test string
XNAME2=more
XXYZZY=garbage}
X
Xset env(NAME2) "new value"
Xtest env-2.1 {changing environment variables} {
X getenv
X} {NAME1=test string
XNAME2=new value
XXYZZY=garbage}
X
Xunset env(NAME2)
Xtest env-3.1 {unsetting environment variables} {
X getenv
X} {NAME1=test string
XXYZZY=garbage}
Xunset env(NAME1)
Xtest env-3.2 {unsetting environment variables} {
X getenv
X} {XYZZY=garbage}
X
X# Restore the environment variables at the end of the test.
X
Xforeach name [array names env] {
X unset env($name)
X}
Xforeach name [array names env2] {
X set env($name) $env2($name)
X}
END_OF_FILE
if test 2832 -ne `wc -c <'tcl6.1/tests/env.test'`; then
echo shar: \"'tcl6.1/tests/env.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/env.test'
fi
if test -f 'tcl6.1/tests/incr.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/incr.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/incr.test'\" $2296 characters$
sed "s/^X//" >'tcl6.1/tests/incr.test' <<'END_OF_FILE'
X# Commands covered: lreplace

X# $Header: /sprite/src/lib/tcl/tests/RCS/incr.test,v 1.2 91/08/28 16:27:35 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {unset x}
X
Xtest incr-1.1 {basic incr operation} {
X set x 23
X list [incr x] $x
X} {24 24}
Xtest incr-1.2 {basic incr operation} {
X set x 106
X list [incr x -5] $x
X} {101 101}
X
Xtest incr-2.1 {incr errors} {
X list [catch incr msg] $msg
X} {1 {wrong # args: should be "incr varName ?increment?"}}
Xtest incr-2.2 {incr errors} {
X list [catch {incr a b c} msg] $msg
X} {1 {wrong # args: should be "incr varName ?increment?"}}
Xtest incr-2.3 {incr errors} {
X catch {unset x}
X list [catch {incr x} msg] $msg $errorInfo
X} {1 {can't read "x": no such variable} {can't read "x": no such variable
X while executing
X"incr x"}}
Xtest incr-2.4 {incr errors} {
X set x abc
X list [catch {incr x} msg] $msg $errorInfo
X} {1 {expected integer but got "abc"} {expected integer but got "abc"
X (reading value of variable to increment)
X invoked from within
X"incr x"}}
Xtest incr-2.5 {incr errors} {
X set x 123
X list [catch {incr x 1a} msg] $msg $errorInfo
X} {1 {expected integer but got "1a"} {expected integer but got "1a"
X (reading increment)
X invoked from within
X"incr x 1a"}}
Xtest incr-2.6 {incr errors} {
X proc readonly args {error "variable is read-only"}
X set x 123
X trace var x w readonly
X list [catch {incr x 1} msg] $msg $errorInfo
X} {1 {can't set "x": access disallowed by trace command} {can't set "x": access disallowed by trace command
X while executing
X"incr x 1"}}
X
Xcatch {unset x}
Xconcat {}
END_OF_FILE
if test 2296 -ne `wc -c <'tcl6.1/tests/incr.test'`; then
echo shar: \"'tcl6.1/tests/incr.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/incr.test'
fi
if test -f 'tcl6.1/tests/lindex.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/lindex.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/lindex.test'\" $2290 characters$
sed "s/^X//" >'tcl6.1/tests/lindex.test' <<'END_OF_FILE'
X# Commands covered: lindex

X# $Header: /sprite/src/lib/tcl/tests/RCS/lindex.test,v 1.1 91/09/06 14:48:02 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest lindex-1.1 {basic tests} {
X lindex {a b c} 0} a
Xtest lindex-1.2 {basic tests} {
X lindex {a {b c d} x} 1} {b c d}
Xtest lindex-1.3 {basic tests} {
X lindex {a b\ c\ d x} 1} {b c d}
Xtest lindex-1.4 {basic tests} {
X lindex {a b c} 3} {}
Xtest lindex-1.5 {basic tests} {
X list [catch {lindex {a b c} -1} msg] $msg
X} {0 {}}
X
Xtest lindex-2.1 {error conditions} {
X list [catch {lindex msg} msg] $msg
X} {1 {wrong # args: should be "lindex list index"}}
Xtest lindex-2.2 {error conditions} {
X list [catch {lindex 1 2 3 4} msg] $msg
X} {1 {wrong # args: should be "lindex list index"}}
Xtest lindex-2.3 {error conditions} {
X list [catch {lindex 1 2a2} msg] $msg
X} {1 {expected integer but got "2a2"}}
Xtest lindex-2.4 {error conditions} {
X list [catch {lindex "a \{" 2} msg] $msg

X} {1 {unmatched open brace in list}}

Xtest lindex-2.5 {error conditions} {
X list [catch {lindex {a {b c}d e} 2} msg] $msg
X} {1 {list element in braces followed by "d" instead of space}}
Xtest lindex-2.6 {error conditions} {
X list [catch {lindex {a "b c"def ghi} 2} msg] $msg
X} {1 {list element in quotes followed by "def" instead of space}}
X
Xtest lindex-3.1 {quoted elements} {
X lindex {a "b c" d} 1
X} {b c}
Xtest lindex-3.2 {quoted elements} {
X lindex {"{}" b c} 0
X} {{}}
Xtest lindex-3.3 {quoted elements} {
X lindex {ab "c d \" x" y} 1
X} {c d " x}
Xtest lindex-3.4 {quoted elements} {
X lindex {a b {c d "e} {f g"}} 2
X} {c d "e}
END_OF_FILE
if test 2290 -ne `wc -c <'tcl6.1/tests/lindex.test'`; then
echo shar: \"'tcl6.1/tests/lindex.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/lindex.test'
fi
if test -f 'tcl6.1/tests/linsert.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/linsert.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/linsert.test'\" $2399 characters$
sed "s/^X//" >'tcl6.1/tests/linsert.test' <<'END_OF_FILE'
X# Commands covered: linsert

X# $Header: /sprite/src/lib/tcl/tests/RCS/linsert.test,v 1.1 91/08/21 13:37:24 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest linsert-1.1 {linsert command} {
X linsert {1 2 3 4 5} 0 a
X} {a 1 2 3 4 5}
Xtest linsert-1.2 {linsert command} {
X linsert {1 2 3 4 5} 1 a
X} {1 a 2 3 4 5}
Xtest linsert-1.3 {linsert command} {
X linsert {1 2 3 4 5} 2 a
X} {1 2 a 3 4 5}
Xtest linsert-1.4 {linsert command} {
X linsert {1 2 3 4 5} 3 a
X} {1 2 3 a 4 5}
Xtest linsert-1.5 {linsert command} {
X linsert {1 2 3 4 5} 4 a
X} {1 2 3 4 a 5}
Xtest linsert-1.6 {linsert command} {
X linsert {1 2 3 4 5} 5 a
X} {1 2 3 4 5 a}
Xtest linsert-1.7 {linsert command} {
X linsert {1 2 3 4 5} 2 one two \{three \$four
X} {1 2 one two \{three {$four} 3 4 5}
Xtest linsert-1.8 {linsert command} {
X linsert {\{one \$two \{three \ four \ five} 2 a b c
X} {\{one \$two a b c \{three \ four \ five}
Xtest linsert-1.9 {linsert command} {
X linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b}
X} {{1 2} {3 4} {x y} {a b} {5 6} {7 8}}
Xtest linsert-1.10 {linsert command} {
X linsert {} 2 a b c
X} {a b c}
Xtest linsert-1.11 {linsert command} {
X linsert {} 2 {}
X} {{}}
X
Xtest linsert-2.1 {linsert errors} {
X list [catch linsert msg] $msg
X} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
Xtest linsert-2.2 {linsert errors} {
X list [catch {linsert a b} msg] $msg
X} {1 {wrong # args: should be "linsert list index element ?element ...?"}}
Xtest linsert-2.3 {linsert errors} {
X list [catch {linsert a 12x 2} msg] $msg
X} {1 {expected integer but got "12x"}}
Xtest linsert-2.4 {linsert errors} {
X list [catch {linsert \{ 12 2} msg] $msg

X} {1 {unmatched open brace in list}}
END_OF_FILE

if test 2399 -ne `wc -c <'tcl6.1/tests/linsert.test'`; then
echo shar: \"'tcl6.1/tests/linsert.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/linsert.test'
fi
if test -f 'tcl6.1/tests/list.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/list.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/list.test'\" $2924 characters$
sed "s/^X//" >'tcl6.1/tests/list.test' <<'END_OF_FILE'
X# Commands covered: list

X# $Header: /user6/ouster/tcl/tests/RCS/list.test,v 1.9 91/10/17 15:49:39 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# First, a bunch of individual tests
X
Xtest list-1.1 {basic tests} {list a b c} {a b c}
Xtest list-1.2 {basic tests} {list {a b} c} {{a b} c}
Xtest list-1.3 {basic tests} {list \{a b c} {\{a b c}
Xtest list-1.4 {basic tests} "list a{}} b{} c}" "a{}} b{} c}"
Xtest list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]"
Xtest list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}"
Xtest list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}"
Xtest list-1.8 {basic tests} {list g\; h\\} {{g;} h\\}
Xtest list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[} b\\\]}"
Xtest list-1.10 {basic tests} "list c\\\} d\\t} " "c} d\\t}"
Xtest list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n} f\\$}"
Xtest list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;} {h\\}}"
Xtest list-1.13 {basic tests} {list a {{}} b} {a {{}} b}
Xtest list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\"
Xtest list-1.15 {basic tests} "list a b\} e\\" "a b} e\\\\"
Xtest list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\}\\\$ e\\\$\\\\"
Xtest list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f"
Xtest list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r"
Xtest list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v"
X
X# For the next round of tests create a list and then pick it apart
X# with "index" to make sure that we get back exactly what went in.
X
Xset num 1
Xproc lcheck {a b c} {
X global num d
X set d [list $a $b $c]
X test list-2.$num {what goes in must come out} {lindex $d 0} $a
X set num [expr $num+1]
X test list-2.$num {what goes in must come out} {lindex $d 1} $b
X set num [expr $num+1]
X test list-2.$num {what goes in must come out} {lindex $d 2} $c
X set num [expr $num+1]
X}
Xlcheck a b c
Xlcheck "a b" c\td e\nf
Xlcheck {{a b}} {} { }
Xlcheck \$ \$ab ab\$
Xlcheck \; \;ab ab\;
Xlcheck \[ \[ab ab\[
Xlcheck \\ \\ab ab\\
Xlcheck {"} {"ab} {ab"}
Xlcheck {a b} { ab} {ab }
Xlcheck a{ a{b \{ab
Xlcheck a} a}b }ab
Xlcheck a\\} {a \}b} {a \{c}
X
Xtest list-3.1 {error conditions} {catch list msg} 1
Xtest list-3.2 {error conditions} {
X catch list msg
X set msg
X} {wrong # args: should be "list arg ?arg ...?"}
END_OF_FILE
if test 2924 -ne `wc -c <'tcl6.1/tests/list.test'`; then
echo shar: \"'tcl6.1/tests/list.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/list.test'
fi
if test -f 'tcl6.1/tests/lrange.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/lrange.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/lrange.test'\" $2523 characters$
sed "s/^X//" >'tcl6.1/tests/lrange.test' <<'END_OF_FILE'
X# Commands covered: lrange

X# $Header: /sprite/src/lib/tcl/tests/RCS/lrange.test,v 1.1 91/09/06 14:47:58 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest lrange-1.1 {range of list elements} {
X lrange {a b c d} 1 2
X} {b c}
Xtest lrange-1.2 {range of list elements} {
X lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
X} {{bcd e {f g {}}}}
Xtest lrange-1.3 {range of list elements} {
X lrange {a {bcd e {f g {}}} l14 l15 d} 3 end
X} {l15 d}
Xtest lrange-1.4 {range of list elements} {
X lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000
X} {d}
Xtest lrange-1.5 {range of list elements} {
X lrange {a {bcd e {f g {}}} l14 l15 d} 4 3
X} {}
Xtest lrange-1.6 {range of list elements} {
X lrange {a {bcd e {f g {}}} l14 l15 d} 10 11
X} {}
Xtest lrange-1.7 {range of list elements} {
X lrange {a b c d e} -1 2
X} {a b c}
Xtest lrange-1.8 {range of list elements} {
X lrange {a b c d e} -2 -1
X} {}
Xtest lrange-1.9 {range of list elements} {
X lrange {a b c d e} -2 e

X} {a b c d e}

Xtest lrange-1.10 {range of list elements} {
X lrange "a b\{c d" 1 2
X} "b\{c d"
X
Xtest lrange-2.1 {error conditions} {
X list [catch {lrange a b} msg] $msg
X} {1 {wrong # args: should be "lrange list first last"}}
Xtest lrange-2.2 {error conditions} {
X list [catch {lrange a b 6 7} msg] $msg
X} {1 {wrong # args: should be "lrange list first last"}}
Xtest lrange-2.3 {error conditions} {
X list [catch {lrange a b 6} msg] $msg
X} {1 {expected integer but got "b"}}
Xtest lrange-2.4 {error conditions} {
X list [catch {lrange a 0 enigma} msg] $msg
X} {1 {expected integer or "end" but got "enigma"}}
Xtest lrange-2.5 {error conditions} {
X list [catch {lrange "a \{b c" 3 4} msg] $msg

X} {1 {unmatched open brace in list}}

Xtest lrange-2.6 {error conditions} {
X list [catch {lrange "a b c \{ d e" 1 4} msg] $msg

X} {1 {unmatched open brace in list}}
END_OF_FILE

if test 2523 -ne `wc -c <'tcl6.1/tests/lrange.test'`; then
echo shar: \"'tcl6.1/tests/lrange.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/lrange.test'
fi
if test -f 'tcl6.1/tests/lreplace.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/lreplace.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/lreplace.test'\" $2951 characters$
sed "s/^X//" >'tcl6.1/tests/lreplace.test' <<'END_OF_FILE'
X# Commands covered: lreplace

X# $Header: /sprite/src/lib/tcl/tests/RCS/lreplace.test,v 1.2 91/08/21 13:59:19 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest lreplace-1.1 {lreplace command} {
X lreplace {1 2 3 4 5} 0 0 a
X} {a 2 3 4 5}
Xtest lreplace-1.2 {lreplace command} {
X lreplace {1 2 3 4 5} 1 1 a
X} {1 a 3 4 5}
Xtest lreplace-1.3 {lreplace command} {
X lreplace {1 2 3 4 5} 2 2 a
X} {1 2 a 4 5}
Xtest lreplace-1.4 {lreplace command} {
X lreplace {1 2 3 4 5} 3 3 a
X} {1 2 3 a 5}
Xtest lreplace-1.5 {lreplace command} {
X lreplace {1 2 3 4 5} 4 4 a
X} {1 2 3 4 a}
Xtest lreplace-1.6 {lreplace command} {
X lreplace {1 2 3 4 5} 4 5 a
X} {1 2 3 4 a}
Xtest lreplace-1.7 {lreplace command} {
X lreplace {1 2 3 4 5} -1 -1 a
X} {a 2 3 4 5}
Xtest lreplace-1.8 {lreplace command} {
X lreplace {1 2 3 4 5} 2 end a b c d
X} {1 2 a b c d}
Xtest lreplace-1.9 {lreplace command} {
X lreplace {1 2 3 4 5} 0 3
X} {5}
Xtest lreplace-1.10 {lreplace command} {
X lreplace {1 2 3 4 5} 0 4
X} {}
Xtest lreplace-1.11 {lreplace command} {
X lreplace {1 2 3 4 5} 0 1
X} {3 4 5}
Xtest lreplace-1.12 {lreplace command} {
X lreplace {1 2 3 4 5} 2 3
X} {1 2 5}
Xtest lreplace-1.13 {lreplace command} {
X lreplace {1 2 3 4 5} 3 end
X} {1 2 3}
Xtest lreplace-1.14 {lreplace command} {
X lreplace {1 2 3 4 5} -1 4 a b c

X} {a b c}
X

Xtest lreplace-2.1 {lreplace errors} {
X list [catch lreplace msg] $msg
X} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
Xtest lreplace-2.2 {lreplace errors} {
X list [catch {lreplace a b} msg] $msg
X} {1 {wrong # args: should be "lreplace list first last ?element element ...?"}}
Xtest lreplace-2.3 {lreplace errors} {
X list [catch {lreplace x a 10} msg] $msg
X} {1 {expected integer but got "a"}}
Xtest lreplace-2.4 {lreplace errors} {
X list [catch {lreplace x 10 x} msg] $msg
X} {1 {bad index "x": must be integer or "end"}}
Xtest lreplace-2.5 {lreplace errors} {
X list [catch {lreplace x 10 1x} msg] $msg
X} {1 {expected integer but got "1x"}}
Xtest lreplace-2.6 {lreplace errors} {
X list [catch {lreplace x 3 2} msg] $msg
X} {1 {first index must not be greater than second}}
Xtest lreplace-2.7 {lreplace errors} {
X list [catch {lreplace x 1 1} msg] $msg
X} {1 {list doesn't contain element 1}}
END_OF_FILE
if test 2951 -ne `wc -c <'tcl6.1/tests/lreplace.test'`; then
echo shar: \"'tcl6.1/tests/lreplace.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/lreplace.test'
fi
if test -f 'tcl6.1/tests/rename.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/rename.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/rename.test'\" $2522 characters$
sed "s/^X//" >'tcl6.1/tests/rename.test' <<'END_OF_FILE'
X# Commands covered: rename

X# $Header: /sprite/src/lib/tcl/tests/RCS/rename.test,v 1.4 91/08/14 11:45:18 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {rename r2 {}}
Xproc r1 {} {return "procedure r1"}
Xrename r1 r2
Xtest rename-1.1 {simple renaming} {
X r2
X} {procedure r1}
Xtest rename-1.2 {simple renaming} {
X list [catch r1 msg] $msg
X} {1 {invalid command name: "r1"}}
Xrename r2 {}
Xtest rename-1.3 {simple renaming} {
X list [catch r2 msg] $msg
X} {1 {invalid command name: "r2"}}
X
X# The test below is tricky because it renames a built-in command.
X# It's possible that the test procedure uses this command, so must
X# restore the command before calling test again.
X
Xrename list l.new
Xset a [catch list msg1]
Xset b [l.new a b c]
Xrename l.new list
Xset c [catch l.new msg2]
Xset d [list 111 222]
Xtest 2.1 {renaming built-in command} {
X list $a $msg1 $b $c $msg2 $d
X} {1 {invalid command name: "list"} {a b c} 1 {invalid command name: "l.new"} {111 222}}
X
Xtest rename-3.1 {error conditions} {
X list [catch {rename r1} msg] $msg $errorCode
X} {1 {wrong # args: should be "rename oldName newName"} NONE}
Xtest rename-3.2 {error conditions} {
X list [catch {rename r1 r2 r3} msg] $msg $errorCode
X} {1 {wrong # args: should be "rename oldName newName"} NONE}
Xtest rename-3.3 {error conditions} {
X proc r1 {} {}
X proc r2 {} {}
X list [catch {rename r1 r2} msg] $msg
X} {1 {can't rename to "r2": command already exists}}
Xtest rename-3.4 {error conditions} {
X catch {rename r1 {}}
X catch {rename r2 {}}
X list [catch {rename r1 r2} msg] $msg
X} {1 {can't rename "r1": command doesn't exist}}
Xtest rename-3.5 {error conditions} {
X catch {rename _non_existent_command {}}
X list [catch {rename _non_existent_command {}} msg] $msg
X} {1 {can't delete "_non_existent_command": command doesn't exist}}
END_OF_FILE
if test 2522 -ne `wc -c <'tcl6.1/tests/rename.test'`; then
echo shar: \"'tcl6.1/tests/rename.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/rename.test'
fi
if test -f 'tcl6.1/tests/source.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/source.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/source.test'\" $2609 characters$
sed "s/^X//" >'tcl6.1/tests/source.test' <<'END_OF_FILE'
X# Commands covered: source

X# $Header: /sprite/src/lib/tcl/tests/RCS/source.test,v 1.6 91/09/11 17:30:17 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest source-1.1 {source command} {
X set x "old x value"
X set y "old y value"
X set z "old z value"
X exec cat << {
X set x 22
X set y 33
X set z 44
X } > source.file
X source source.file
X list $x $y $z
X} {22 33 44}
Xtest source-1.2 {source command} {
X exec cat << {list result} > source.file
X source source.file
X} result
X
Xtest source-2.1 {source error conditions} {
X list [catch {source} msg] $msg
X} {1 {wrong # args: should be "source fileName"}}
Xtest source-2.2 {source error conditions} {
X list [catch {source a b} msg] $msg
X} {1 {wrong # args: should be "source fileName"}}
Xtest source-2.3 {source error conditions} {
X exec cat << {
X set x 146
X error "error in sourced file"
X set y $x
X } > source.file
X list [catch {source source.file} msg] $msg $errorInfo
X} {1 {error in sourced file} {error in sourced file
X while executing
X"error "error in sourced file""
X (file "source.file" line 3)
X invoked from within
X"source source.file"}}
Xtest source-2.4 {source error conditions} {
X exec cat << {break} > source.file
X catch {source source.file}
X} 3
Xtest source-2.5 {source error conditions} {
X exec cat << {continue} > source.file
X catch {source source.file}
X} 4
Xtest source-2.6 {source error conditions} {
X string tolower [list [catch {source _non_existent_} msg] $msg $errorCode]
X} {1 {couldn't read file "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
X
Xtest source-3.1 {return in middle of source file} {
X exec cat << {
X set x new-x
X return allDone
X set y new-y
X } > source.file
X set x old-x
X set y old-y
X set z [source source.file]
X list $x $y $z
X} {new-x old-y allDone}
X
Xcatch {exec rm source.file}
X
X# Generate null final value
X
Xconcat {}
END_OF_FILE
if test 2609 -ne `wc -c <'tcl6.1/tests/source.test'`; then
echo shar: \"'tcl6.1/tests/source.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/source.test'
fi
if test -f 'tcl6.1/tests/uplevel.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/uplevel.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/uplevel.test'\" $2665 characters$
sed "s/^X//" >'tcl6.1/tests/uplevel.test' <<'END_OF_FILE'
X# Commands covered: uplevel

X# $Header: /sprite/src/lib/tcl/tests/RCS/uplevel.test,v 1.8 91/09/30 16:59:26 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc a {x y} {
X newset z [expr $x+$y]
X return $z
X}
Xproc newset {name value} {
X uplevel set $name $value
X uplevel 1 {uplevel 1 {set xyz 22}}
X}
X
Xtest uplevel-1.1 {simple operation} {
X set xyz 0
X a 22 33
X} 55
Xtest uplevel-1.2 {command is another uplevel command} {
X set xyz 0
X a 22 33
X set xyz
X} 22
X
Xproc a1 {} {
X b1
X global a a1
X set a $x
X set a1 $y
X}
Xproc b1 {} {
X c1
X global b b1
X set b $x
X set b1 $y
X}
Xproc c1 {} {
X uplevel 1 set x 111
X uplevel #2 set y 222
X uplevel 2 set x 333
X uplevel #1 set y 444
X uplevel 3 set x 555
X uplevel #0 set y 666
X}
Xa1
Xtest uplevel-2.1 {relative and absolute uplevel} {set a} 333
Xtest uplevel-2.2 {relative and absolute uplevel} {set a1} 444
Xtest uplevel-2.3 {relative and absolute uplevel} {set b} 111
Xtest uplevel-2.4 {relative and absolute uplevel} {set b1} 222
Xtest uplevel-2.5 {relative and absolute uplevel} {set x} 555
Xtest uplevel-2.6 {relative and absolute uplevel} {set y} 666
X
Xtest uplevel-3.1 {error: non-existent level} {
X list [catch c1 msg] $msg
X} {1 {bad level "#2"}}
Xtest uplevel-3.2 {error: non-existent level} {
X proc c2 {} {uplevel 3 {set a b}}
X list [catch c2 msg] $msg
X} {1 {bad level "3"}}
Xtest uplevel-3.3 {error: already at global level} {
X list [catch {uplevel gorp} msg] $msg
X} {1 {already at top level}}
Xtest uplevel-3.4 {error: already at global level} {
X list [catch {uplevel 1 gorp} msg] $msg
X} {1 {already at top level}}
Xtest uplevel-3.5 {error: not enough args} {
X list [catch uplevel msg] $msg
X} {1 {wrong # args: should be "uplevel ?level? command ?command ...?"}}
X
Xproc a2 {} {
X uplevel a3
X}
Xproc a3 {} {
X global x y
X set x [info level]
X set y [info level 1]
X}
Xa2
Xtest uplevel-4.1 {info level} {set x} 1
Xtest uplevel-4.2 {info level} {set y} a3
END_OF_FILE
if test 2665 -ne `wc -c <'tcl6.1/tests/uplevel.test'`; then
echo shar: \"'tcl6.1/tests/uplevel.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/uplevel.test'
fi
if test -f 'tcl6.1/tests/while.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/while.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/while.test'\" $2870 characters$
sed "s/^X//" >'tcl6.1/tests/while.test' <<'END_OF_FILE'
X# Commands covered: while

X# $Header: /sprite/src/lib/tcl/tests/RCS/while.test,v 1.5 91/09/08 13:43:30 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest while-1.1 {basic while loops} {
X set count 0
X while {$count < 10} {set count [expr $count+1]}
X set count
X} 10
Xtest while-1.2 {basic while loops} {
X set value xxx
X while {2 > 3} {set value yyy}
X set value
X} xxx
X
Xtest while-2.1 {continue in while loop} {
X set list {1 2 3 4 5}
X set index 0
X set result {}
X while {$index < 5} {
X if {$index == 2} {set index [expr $index+1]; continue}
X set result [concat $result [lindex $list $index]]
X set index [expr $index+1]
X }
X set result
X} {1 2 4 5}
X
Xtest while-3.1 {break in while loop} {
X set list {1 2 3 4 5}
X set index 0
X set result {}
X while {$index < 5} {
X if {$index == 3} break
X set result [concat $result [lindex $list $index]]
X set index [expr $index+1]
X }
X set result
X} {1 2 3}
X
Xtest while-4.1 {errors in while loops} {
X set err [catch {while} msg]
X list $err $msg
X} {1 {wrong # args: should be "while test command"}}
Xtest while-4.2 {errors in while loops} {
X set err [catch {while 1} msg]
X list $err $msg
X} {1 {wrong # args: should be "while test command"}}
Xtest while-4.3 {errors in while loops} {
X set err [catch {while 1 2 3} msg]
X list $err $msg
X} {1 {wrong # args: should be "while test command"}}
Xtest while-4.4 {errors in while loops} {
X set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
X list $err $msg
X} {1 {can't use non-numeric string as operand of "+"}}
Xtest while-4.5 {errors in while loops} {
X set x 1
X set err [catch {while {$x} {set x foo}} msg]
X list $err $msg
X} {1 {expression didn't have numeric value}}
Xtest while-4.6 {errors in while loops} {
X set err [catch {while {1} {error "loop aborted"}} msg]
X list $err $msg $errorInfo
X} {1 {loop aborted} {loop aborted
X while executing
X"error "loop aborted""
X ("while" body line 1)
X invoked from within
X"while {1} {error "loop aborted"}"}}
X
Xtest while-5.1 {while return result} {
X while {0} {set a 400}
X} {}
Xtest while-5.2 {while return result} {
X set x 1
X while {$x} {set x 0}
X} {}
END_OF_FILE
if test 2870 -ne `wc -c <'tcl6.1/tests/while.test'`; then
echo shar: \"'tcl6.1/tests/while.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/while.test'
fi
echo shar: End of archive 2 $of 33$.
cp /dev/null ark2isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:26:07 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 71
Archive-name: tcl/part03
Environment: UNIX

# "End of archive 3 (of 33)."
# Contents: tcl6.1/compat/strtoul.c tcl6.1/doc/StrMatch.man
# tcl6.1/library/init.tcl tcl6.1/tclGet.c tcl6.1/tclHash.h
# tcl6.1/tests/README tcl6.1/tests/error.test tcl6.1/tests/for.test
# tcl6.1/tests/glob.test tcl6.1/tests/if.test
# Wrapped by karl@one on Tue Nov 12 19:44:12 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/compat/strtoul.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/strtoul.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/strtoul.c'\" $4318 characters$
sed "s/^X//" >'tcl6.1/compat/strtoul.c' <<'END_OF_FILE'
X/*
X * strtoul.c --
X *
X * Source code for the "strtoul" library procedure.
X *
X * Copyright 1988 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/compat/RCS/strtoul.c,v 1.2 91/09/22 14:04:43 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include <ctype.h>
X
X/*
X * The table below is used to convert from ASCII digits to a
X * numerical equivalent. It maps from '0' through 'z' to integers
X * (100 for non-digit characters).
X */
X
Xstatic char cvtIn[] = {
X 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */
X 100, 100, 100, 100, 100, 100, 100, /* punctuation */
X 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */
X 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
X 30, 31, 32, 33, 34, 35,
X 100, 100, 100, 100, 100, 100, /* punctuation */
X 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */
X 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
X 30, 31, 32, 33, 34, 35};

X
X/*
X *----------------------------------------------------------------------
X *

X * strtoul --
X *

X * Convert an ASCII string into an integer.

X *
X * Results:

X * and *endPtr is set to string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xunsigned long int
Xstrtoul(string, endPtr, base)

X char *string; /* String of ASCII digits, possibly
X * preceded by white space. For bases
X * greater than 10, either lower- or
X * upper-case digits may be used.
X */
X char **endPtr; /* Where to store address of terminating
X * character, or NULL. */
X int base; /* Base for conversion. Must be less
X * than 37. If 0, then the base is chosen
X * from the leading characters of string:
X * "0x" means hex, "0" means octal, anything
X * else means decimal.

X */
X{
X register char *p;
X register unsigned long int result = 0;
X register unsigned digit;
X int anyDigits = 0;

X
X /*
X * Skip any leading blanks.
X */
X
X p = string;
X while (isspace(*p)) {
X p += 1;
X }
X
X /*

X * If no base was provided, pick one from the leading characters
X * of the string.
X */
X
X if (base == 0)
X {
X if (*p == '0') {
X p += 1;
X if (*p == 'x') {
X p += 1;
X base = 16;
X } else {
X
X /*
X * Must set anyDigits here, otherwise "0" produces a
X * "no digits" error.
X */
X
X anyDigits = 1;
X base = 8;
X }
X }
X else base = 10;
X } else if (base == 16) {
X
X /*
X * Skip a leading "0x" from hex numbers.
X */
X
X if ((p[0] == '0') && (p[1] == 'x')) {
X p += 2;
X }
X }
X
X /*
X * Sorry this code is so messy, but speed seems important. Do
X * different things for base 8, 10, 16, and other.
X */
X
X if (base == 8) {
X for ( ; ; p += 1) {
X digit = *p - '0';
X if (digit > 7) {
X break;
X }
X result = (result << 3) + digit;
X anyDigits = 1;
X }
X } else if (base == 10) {
X for ( ; ; p += 1) {
X digit = *p - '0';
X if (digit > 9) {
X break;
X }
X result = (10*result) + digit;
X anyDigits = 1;
X }
X } else if (base == 16) {
X for ( ; ; p += 1) {
X digit = *p - '0';
X if (digit > ('z' - '0')) {
X break;
X }
X digit = cvtIn[digit];
X if (digit > 15) {
X break;
X }
X result = (result << 4) + digit;
X anyDigits = 1;
X }
X } else {
X for ( ; ; p += 1) {
X digit = *p - '0';
X if (digit > ('z' - '0')) {
X break;
X }
X digit = cvtIn[digit];
X if (digit >= base) {
X break;
X }
X result = result*base + digit;
X anyDigits = 1;
X }
X }
X
X /*
X * See if there were any digits at all.
X */
X
X if (!anyDigits) {

X p = string;
X }

X
X if (endPtr != 0) {
X *endPtr = p;
X }

X
X return result;
X}
END_OF_FILE

if test 4318 -ne `wc -c <'tcl6.1/compat/strtoul.c'`; then
echo shar: \"'tcl6.1/compat/strtoul.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/strtoul.c'
fi
if test -f 'tcl6.1/doc/StrMatch.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/StrMatch.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/StrMatch.man'\" $4906 characters$
sed "s/^X//" >'tcl6.1/doc/StrMatch.man' <<'END_OF_FILE'
X'\" Copyright 1989 Regents of the University of California
X'\" Permission to use, copy, modify, and distribute this
X'\" documentation for any purpose and without fee is hereby
X'\" granted, provided that this notice appears in all copies.
X'\" The University of California makes no representations about
X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/StrMatch.man,v 1.2 91/04/03 15:14:14 ouster Exp $ SPRITE (Berkeley)
X'\"
X.\" The definitions below are for supplemental macros used in Sprite
X.\" manual entries.
X.\"
X.\" .HS name section [date [version]]
X.\" Replacement for .TH in other man pages. See below for valid
X.\" section names.
X.\"
X.\" .AP type name in/out [indent]
X.\" Start paragraph describing an argument to a library procedure.
X.\" type is type of argument (int, etc.), in/out is either "in", "out",
X.\" or "in/out" to describe whether procedure reads or modifies arg,
X.\" and indent is equivalent to second arg of .IP (shouldn't ever be
X.\" needed; use .AS below instead)
X.\"
X.\" .AS [type [name]]
X.\" Give maximum sizes of arguments for setting tab stops. Type and
X.\" name are examples of largest possible arguments that will be passed
X.\" to .AP later. If args are omitted, default tab stops are used.
X.\"
X.\" .BS
X.\" Start box enclosure. From here until next .BE, everything will be
X.\" enclosed in one large box.
X.\"
X.\" .BE
X.\" End of box enclosure.
X.\"
X.\" .VS
X.\" Begin vertical sidebar, for use in marking newly-changed parts
X.\" of man pages.
X.\"
X.\" .VE
X.\" End of vertical sidebar.
X.\"
X.\" .DS
X.\" Begin an indented unfilled display.
X.\"
X.\" .DE
X.\" End of indented unfilled display.
X.\"
X' # Heading for Sprite man pages
X.de HS
X.if '\\$2'cmds' .TH \\$1 1 \\$3 \\$4
X.if '\\$2'lib' .TH \\$1 3 \\$3 \\$4
X.if '\\$2'tcl' .TH \\$1 3 \\$3 \\$4
X.if '\\$2'tk' .TH \\$1 3 \\$3 \\$4
X.if t .wh -1.3i ^B
X.nr ^l \\n(.l
X.ad b
X..
X' # Start an argument description
X.de AP
X.ie !"\\$4"" .TP \\$4
X.el \{\
X. ie !"\\$2"" .TP \\n()Cu
X. el .TP 15
X.\}
X.ie !"\\$3"" \{\
X.ta \\n()Au \\n()Bu
X\&\\$1 \\fI\\$2\\fP (\\$3)
X.\".b
X.\}
X.el \{\
X.br
X.ie !"\\$2"" \{\
X\&\\$1 \\fI\\$2\\fP
X.\}
X.el \{\
X\&\\fI\\$1\\fP
X.\}
X.\}
X..
X' # define tabbing values for .AP
X.de AS
X.nr )A 10n
X.if !"\\$1"" .nr )A \\w'\\$1'u+3n
X.nr )B \\n()Au+15n
X.\"
X.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
X.nr )C \\n()Bu+\\w'(in/out)'u+2n
X..
X' # BS - start boxed text
X' # ^y = starting y location
X' # ^b = 1
X.de BS
X.br
X.mk ^y
X.nr ^b 1u
X.if n .nf
X.if n .ti 0
X.if n \l'\\n(.lu\(ul'
X.if n .fi
X..
X' # BE - end boxed text (draw box now)
X.de BE
X.nf
X.ti 0
X.mk ^t
X.ie n \l'\\n(^lu\(ul'
X.el \{\
X.\" Draw four-sided box normally, but don't draw top of
X.\" box if the box started on an earlier page.
X.ie !\\n(^b-1 \{\
X\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
X.\}
X.el \}\
X\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
X.\}
X.\}
X.fi
X.br
X.nr ^b 0
X..
X' # VS - start vertical sidebar
X' # ^Y = starting y location
X' # ^v = 1 (for troff; for nroff this doesn't matter)
X.de VS
X.mk ^Y
X.ie n 'mc \s12\(br\s0
X.el .nr ^v 1u
X..
X' # VE - end of vertical sidebar
X.de VE
X.ie n 'mc
X.el \{\
X.ev 2
X.nf
X.ti 0
X.mk ^t
X\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
X.sp -1
X.fi
X.ev
X.\}
X.nr ^v 0
X..
X' # Special macro to handle page bottom: finish off current
X' # box/sidebar if in box/sidebar mode, then invoked standard
X' # page bottom macro.
X.de ^B
X.ev 2
X'ti 0
X'nf
X.mk ^t
X.if \\n(^b \{\
X.\" Draw three-sided box if this is the box's first page,
X.\" draw two sides but no top otherwise.
X.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
X.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
X.\}
X.if \\n(^v \{\
X.nr ^x \\n(^tu+1v-\\n(^Yu
X\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
X.\}
X.bp
X'fi
X.ev
X.if \\n(^b \{\
X.mk ^y
X.nr ^b 2
X.\}
X.if \\n(^v \{\
X.mk ^Y
X.\}
X..
X' # DS - begin display
X.de DS
X.RS
X.nf
X.sp
X..
X' # DE - end display
X.de DE
X.fi
X.RE
X.sp .5
X..
X.HS Tcl_StringMatch tcl
X.BS
X.SH NAME
XTcl_StringMatch \- test whether a string matches a pattern
X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp
Xint
X\Tcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR)
X.SH ARGUMENTS
X.AP char *string in
XString to test.
X.AP char *pattern in
XPattern to match against string. May contain special
Xcharacters from the set *?\e[].
X.BE
X
X.SH DESCRIPTION
X.PP
XThis utility procedure determines whether a string matches
Xa given pattern. If it does, then \fBTcl_StringMatch\fR returns
X1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm
Xused for matching is the same algorithm used in the ``string match''
XTcl command and is similar to the algorithm used by the C-shell
Xfor file name matching; see the Tcl manual entry for details.
X
X.SH KEYWORDS
Xmatch, pattern, string
END_OF_FILE
if test 4906 -ne `wc -c <'tcl6.1/doc/StrMatch.man'`; then
echo shar: \"'tcl6.1/doc/StrMatch.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/StrMatch.man'
fi
if test -f 'tcl6.1/library/init.tcl' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/library/init.tcl'\"
else
echo shar: Extracting \"'tcl6.1/library/init.tcl'\" $3973 characters$
sed "s/^X//" >'tcl6.1/library/init.tcl' <<'END_OF_FILE'
X# init.tcl --
X#
X# Default system startup file for Tcl-based applications. Defines
X# "unknown" procedure and auto-load facilities.
X#
X# $Header: /sprite/src/lib/tcl/scripts/RCS/init.tcl,v 1.2 91/09/26 10:05:45 ouster Exp $ SPRITE (Berkeley)

X#
X# Copyright 1991 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 this copyright
X# notice appears 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# unknown:
X# Invoked when a Tcl command is invoked that doesn't exist in the
X# interpreter:
X#
X# 1. See if the autoload facility can locate the command in a
X# Tcl script file. If so, load it and execute it.
X# 2. See if the command exists as an executable UNIX program.
X# If so, "exec" the command.
X# 3. See if the command is a valid abbreviation for another command.
X# if so, invoke the command. However, only permit abbreviations
X# at top-level.
X
Xproc unknown args {
X global auto_noexec auto_noload env unknown_active
X
X if [info exists unknown_active] {
X unset unknown_active
X error "unexpected recursion in \"unknown\" command"
X }
X set unknown_active 1
X set name [lindex $args 0]
X if ![info exists auto_noload] {
X if [auto_load $name] {
X unset unknown_active
X return [uplevel $args]
X }
X }
X if ![info exists auto_noexec] {
X if [auto_execok $name] {
X unset unknown_active
X return [uplevel exec $args]
X }
X }
X if {([info level] == 1) && ([info script] == "")} {
X set cmds [info commands $name*]
X if {[llength $cmds] == 1} {
X unset unknown_active
X return [uplevel [lreplace $args 0 0 $cmds]]
X }
X if {[llength $cmds] != 0} {
X unset unknown_active
X error "ambiguous command name \"$name\": $cmds"
X }
X }
X unset unknown_active
X error "invalid command name \"$name\""
X}
X
X# auto_load:
X# Checks a collection of library directories to see if a procedure
X# is defined in one of them. If so, it sources the appropriate
X# library file to create the procedure. Returns 1 if it successfully
X# loaded the procedure, 0 otherwise.
X
Xproc auto_load cmd {
X global auto_index auto_path env
X
X if [info exists auto_index($cmd)] {
X source $auto_index($cmd)
X return 1
X }
X if [catch {set path $auto_path}] {
X if [catch {set path $env(TCLLIBPATH)}] {
X if [catch {set path [info library]}] {
X return 0
X }
X }
X }
X foreach dir $path {
X set f ""
X catch {
X set f [open $dir/tclIndex]
X if {[gets $f] != "# Tcl autoload index file: each line identifies a Tcl"} {
X puts stdout "Bad id line in file $dir/tclIndex"
X error done
X }

X while {[gets $f line] >= 0} {

X if {([string index $line 0] == "#") || ([llength $line] != 2)} {
X continue
X }
X set name [lindex $line 0]
X if {![info exists auto_index($name)]} {
X set auto_index($name) $dir/[lindex $line 1]
X }
X }
X }
X if {$f != ""} {
X close $f
X }
X }
X if [info exists auto_index($cmd)] {
X source $auto_index($cmd)
X return 1

X }
X return 0
X}

X
X# auto_execok:
X# Returns 1 if there's an executable in the current path for the
X# given name, 0 otherwise. Builds an associative array auto_execs
X# that caches information about previous checks, for speed.
X
Xproc auto_execok name {
X global auto_execs env
X
X if [info exists auto_execs($name)] {
X return $auto_execs($name)
X }
X set auto_execs($name) 0
X foreach dir [split $env(PATH) :] {
X if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
X set auto_execs($name) 1
X return 1
X }

X }
X return 0
X}

X
X# auto_reset:
X# Destroy all cached information for auto-loading and auto-execution,
X# so that the information gets recomputed the next time it's needed.
X
Xproc auto_reset {} {
X global auto_execs auto_index
X unset auto_execs auto_index
X}
END_OF_FILE
if test 3973 -ne `wc -c <'tcl6.1/library/init.tcl'`; then
echo shar: \"'tcl6.1/library/init.tcl'\" unpacked with wrong size!
fi
# end of 'tcl6.1/library/init.tcl'
fi
if test -f 'tcl6.1/tclGet.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclGet.c'\"
else
echo shar: Extracting \"'tcl6.1/tclGet.c'\" $5017 characters$
sed "s/^X//" >'tcl6.1/tclGet.c' <<'END_OF_FILE'
X/*
X * tclGet.c --
X *
X * This file contains procedures to convert strings into
X * other forms, like integers or floating-point numbers or
X * booleans, doing syntax checking along the way.
X *
X * Copyright 1990-1991 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/tclGet.c,v 1.10 91/09/04 16:53:25 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X
Xdouble strtod();
X

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GetInt --
X *
X * Given a string, produce the corresponding integer value.

X *
X * Results:

X * The return value is normally TCL_OK; in this case *intPtr
X * will be set to the integer value equivalent to string. If
X * string is improperly formed then TCL_ERROR is returned and
X * an error message will be left in interp->result.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_GetInt(interp, string, intPtr)
X Tcl_Interp *interp; /* Interpreter to use for error reporting. */
X char *string; /* String containing a (possibly signed)
X * integer in a form acceptable to strtol. */
X int *intPtr; /* Place to store converted result. */
X{
X char *end;
X int i;
X
X i = strtol(string, &end, 0);
X while ((*end != '\0') && isspace(*end)) {
X end++;
X }
X if ((end == string) || (*end != 0)) {
X Tcl_AppendResult(interp, "expected integer but got \"", string,
X "\"", (char *) NULL);
X return TCL_ERROR;
X }
X *intPtr = i;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GetDouble --
X *
X * Given a string, produce the corresponding double-precision
X * floating-point value.

X *
X * Results:

X * The return value is normally TCL_OK; in this case *doublePtr
X * will be set to the double-precision value equivalent to string.
X * If string is improperly formed then TCL_ERROR is returned and
X * an error message will be left in interp->result.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_GetDouble(interp, string, doublePtr)
X Tcl_Interp *interp; /* Interpreter to use for error reporting. */
X char *string; /* String containing a floating-point number
X * in a form acceptable to strtod. */
X double *doublePtr; /* Place to store converted result. */
X{
X char *end;
X double d;
X
X d = strtod(string, &end);
X while ((*end != '\0') && isspace(*end)) {
X end++;
X }
X if ((end == string) || (*end != 0)) {
X Tcl_AppendResult(interp, "expected floating-point number but got \"",
X string, "\"", (char *) NULL);
X return TCL_ERROR;
X }
X *doublePtr = d;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GetBoolean --
X *
X * Given a string, return a 0/1 boolean value corresponding
X * to the string.

X *
X * Results:

X * The return value is normally TCL_OK; in this case *boolPtr
X * will be set to the 0/1 value equivalent to string. If
X * string is improperly formed then TCL_ERROR is returned and
X * an error message will be left in interp->result.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_GetBoolean(interp, string, boolPtr)
X Tcl_Interp *interp; /* Interpreter to use for error reporting. */
X char *string; /* String containing a boolean number
X * specified either as 1/0 or true/false or
X * yes/no. */
X int *boolPtr; /* Place to store converted result, which
X * will be 0 or 1. */
X{
X char c;
X char lowerCase[10];
X int i, length;
X
X /*
X * Convert the input string to all lower-case.
X */
X
X for (i = 0; i < 9; i++) {
X c = string[i];
X if (c == 0) {
X break;
X }
X if ((c >= 'A') && (c <= 'Z')) {
X c += 'a' - 'A';
X }
X lowerCase[i] = c;
X }
X lowerCase[i] = 0;
X
X length = strlen(lowerCase);
X c = lowerCase[0];
X if ((c == '0') && (lowerCase[1] == '\0')) {
X *boolPtr = 0;
X } else if ((c == '1') && (lowerCase[1] == '\0')) {
X *boolPtr = 1;
X } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) {
X *boolPtr = 1;
X } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) {
X *boolPtr = 0;
X } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) {
X *boolPtr = 1;
X } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) {
X *boolPtr = 0;
X } else {
X Tcl_AppendResult(interp, "expected boolean value but got \"",
X string, "\"", (char *) NULL);
X return TCL_ERROR;
X }
X return TCL_OK;
X}
END_OF_FILE
if test 5017 -ne `wc -c <'tcl6.1/tclGet.c'`; then
echo shar: \"'tcl6.1/tclGet.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclGet.c'
fi
if test -f 'tcl6.1/tclHash.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclHash.h'\"
else
echo shar: Extracting \"'tcl6.1/tclHash.h'\" $4968 characters$
sed "s/^X//" >'tcl6.1/tclHash.h' <<'END_OF_FILE'
X/*
X * tclHash.h --
X *
X * This header file declares the facilities provided by the
X * Tcl hash table procedures.

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 * $Header: /sprite/src/lib/tcl/RCS/tclHash.h,v 1.3 91/08/27 11:36:04 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _TCLHASH
X#define _TCLHASH

X
X#ifndef _TCL
X#include <tcl.h>
X#endif
X
X/*

X * Structure definition for an entry in a hash table. No-one outside
X * Tcl should access any of these fields directly; use the macros
X * defined below.
X */
X
Xtypedef struct Tcl_HashEntry {
X struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this
X * hash bucket, or NULL for end of
X * chain. */
X struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
X struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to
X * first entry in this entry's chain:
X * used for deleting the entry. */
X ClientData clientData; /* Application stores something here
X * with Tcl_SetHashValue. */
X union { /* Key has one of these forms: */
X char *oneWordValue; /* One-word value for key. */
X int words[1]; /* Multiple integer words for key.
X * The actual size will be as large
X * as necessary for this table's
X * keys. */
X char string[4]; /* String for key. The actual size
X * will be as large as needed to hold
X * the key. */
X } key; /* MUST BE LAST FIELD IN RECORD!! */
X} Tcl_HashEntry;
X
X/*
X * Structure definition for a hash table. Must be in tcl.h so clients
X * can allocate space for these structures, but clients should never
X * access any fields in this structure.
X */
X
X#define TCL_SMALL_HASH_TABLE 4
Xtypedef struct Tcl_HashTable {
X Tcl_HashEntry **buckets; /* Pointer to bucket array. Each
X * element points to first entry in
X * bucket's hash chain, or NULL. */
X Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
X /* Bucket array used for small tables
X * (to avoid mallocs and frees). */
X int numBuckets; /* Total number of buckets allocated
X * at **bucketPtr. */
X int numEntries; /* Total number of entries present
X * in table. */
X int rebuildSize; /* Enlarge table when numEntries gets
X * to be this large. */
X int downShift; /* Shift count used in hashing
X * function. Designed to use high-
X * order bits of randomized keys. */
X int mask; /* Mask value used in hashing
X * function. */
X int keyType; /* Type of keys used in this table.
X * It's either TCL_STRING_KEYS,
X * TCL_ONE_WORD_KEYS, or an integer
X * giving the number of ints in a
X */
X Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
X char *key));
X Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
X char *key, int *newPtr));
X} Tcl_HashTable;
X
X/*
X * Structure definition for information used to keep track of searches
X * through hash tables:
X */
X
Xtypedef struct Tcl_HashSearch {
X Tcl_HashTable *tablePtr; /* Table being searched. */
X int nextIndex; /* Index of next bucket to be
X * enumerated after present one. */
X Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the
X * the current bucket. */
X} Tcl_HashSearch;
X
X/*
X * Acceptable key types for hash tables:
X */
X
X#define TCL_STRING_KEYS 0
X#define TCL_ONE_WORD_KEYS 1
X
X/*
X * Macros for clients to use to access fields of hash entries:
X */
X
X#define Tcl_GetHashValue(h) ((h)->clientData)
X#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
X#define Tcl_GetHashKey(tablePtr, h) \
X ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \
X : (h)->key.string))
X
X/*
X * Macros to use for clients to use to invoke find and create procedures
X * for hash tables:
X */
X
X#define Tcl_FindHashEntry(tablePtr, key) \
X (*((tablePtr)->findProc))(tablePtr, key)
X#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
X (*((tablePtr)->createProc))(tablePtr, key, newPtr)
X
X/*
X * Exported procedures:
X */
X
Xextern void Tcl_DeleteHashEntry _ANSI_ARGS_((
X Tcl_HashEntry *entryPtr));
Xextern void Tcl_DeleteHashTable _ANSI_ARGS_((
X Tcl_HashTable *tablePtr));
Xextern Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
X Tcl_HashTable *tablePtr,
X Tcl_HashSearch *searchPtr));
Xextern char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr));
Xextern void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X int keyType));
Xextern Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
X Tcl_HashSearch *searchPtr));
X
X#endif /* _TCLHASH */
END_OF_FILE
if test 4968 -ne `wc -c <'tcl6.1/tclHash.h'`; then
echo shar: \"'tcl6.1/tclHash.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclHash.h'
fi
if test -f 'tcl6.1/tests/README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/README'\"
else
echo shar: Extracting \"'tcl6.1/tests/README'\" $3434 characters$
sed "s/^X//" >'tcl6.1/tests/README' <<'END_OF_FILE'
XTcl Test Suite
X--------------
X
XThis directory contains a set of validation tests for the Tcl
Xcommands. Each of the files whose name ends in ".test" is
Xintended to fully exercise one or a few Tcl commands. The
Xcommands tested by a given file are listed in the first line
Xof the file.
X
XThe simplest way to run a test is to start up tclTest in this
Xdirectory and "source" the test file (for example, type "source
Xparse.test"). To run all of the tests, type "source all". If
Xall goes well then no output will appear. If there are errors
Xthen messages will appear in the format described below.
X
XThe rest of this file provides additional information on the
Xfeatures of the testing environment.
X
XThis approach to testing was designed and initially implemented
Xby Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to
Xher for donating her work back to the public Tcl release.
X
XDefinitions file:
X-----------------
X
XThe file "defs" defines a collection of procedures and variables
Xused to run the tests. It is read in automatically by each of the
X.test files if needed, but once it has been read once it will not
Xbe read again by the .test files. If you change defs while running
Xtests you'll have to "source" it by hand to load its new contents.
X
XTest output:
X------------
X
XNormally, output only appears when there are errors. However, if
Xthe variable VERBOSE is set to 1 then tests will be run in "verbose"
Xmode and output will be generated for each test regardless of
Xwhether it succeeded or failed. Test output consists of the
Xfollowing information:
X
X - the test identifier (which can be used to locate the test code
X in the .test file)
X - a brief description of the test
X - the contents of the test code
X - the actual results produced by the tests
X - a "PASSED" or "FAILED" message
X - the expected results (if the test failed)
X
XYou can set VERBOSE either interactively (after the defs file has been
Xread in), or you can change the default value in "defs".
X
XSelecting tests for execution:
X------------------------------
X
XNormally, all the tests in a file are run whenever the file is
X"source"d. However, you can select a specific set of tests using
Xthe global variable TESTS. This variable contains a pattern; any
Xtest whose identifier matches TESTS will be run. For example,
Xthe following interactive command causes all of the "for" tests in
Xgroups 2 and 4 to be executed:
X
X set TESTS {for-[24]*}
X
XTESTS defaults to *, but you can change the default in "defs" if
Xyou wish.
X
XSaving keystrokes:
X------------------
X
XA convenience procedure named "dotests" is included in file
X"defs". It takes two arguments--the name of the test file (such
Xas "parse.test"), and a pattern selecting the tests you want to
Xexecute. It sets TESTS to the second argument, calls "source" on
Xthe file specified in the first argument, and restores TESTS to
Xits pre-call value at the end.
X
XBatch vs. interactive execution:
X--------------------------------
X
XThe tests can be run in either batch or interactive mode. Batch
Xmode refers to using I/O redirection from a UNIX shell. For example,
Xthe following command causes the tests in the file named "parse.test"
Xto be executed:
X
X tclTest < parse.test > parse.test.results
X
XUsers who want to execute the tests in this fashion need to first
Xensure that the file "defs" has proper values for the global
Xvariables that control the testing environment (VERBOSE and TESTS).
END_OF_FILE
if test 3434 -ne `wc -c <'tcl6.1/tests/README'`; then
echo shar: \"'tcl6.1/tests/README'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/README'
fi
if test -f 'tcl6.1/tests/error.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/error.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/error.test'\" $5000 characters$
sed "s/^X//" >'tcl6.1/tests/error.test' <<'END_OF_FILE'
X# Commands covered: error, catch

X# $Header: /sprite/src/lib/tcl/tests/RCS/error.test,v 1.11 91/08/20 14:18:52 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc foo {} {
X global errorInfo
X set a [catch {format [error glorp2]} b]
X error {Human-generated}
X}
X
Xproc foo2 {} {
X global errorInfo
X set a [catch {format [error glorp2]} b]
X error {Human-generated} $errorInfo
X}
X
X# Catch errors occurring in commands and errors from "error" command
X
Xtest error-1.1 {simple errors from commands} {
X catch {format [string compare]} b
X} 1
X
Xtest error-1.2 {simple errors from commands} {
X catch {format [string compare]} b
X set b
X} {wrong # args: should be "string compare string1 string2"}
X
Xtest error-1.3 {simple errors from commands} {
X catch {format [string compare]} b
X set errorInfo
X} {wrong # args: should be "string compare string1 string2"
X while executing
X"string compare"
X invoked from within
X"format [string compare]..."}
X
Xtest error-1.4 {simple errors from commands} {
X catch {error glorp} b
X} 1
X
Xtest error-1.5 {simple errors from commands} {
X catch {error glorp} b
X set b
X} glorp
X
Xtest error-1.6 {simple errors from commands} {
X catch {catch a b c} b
X} 1
X
Xtest error-1.7 {simple errors from commands} {
X catch {catch a b c} b
X set b
X} {wrong # args: should be "catch command ?varName?"}
X
Xtest error-2.1 {simple errors from commands} {
X catch catch
X} 1
X
X# Check errors nested in procedures. Also check the optional argument
X# to "error" to generate a new error trace.
X
Xtest error-2.1 {errors in nested procedures} {
X catch foo b
X} 1
X
Xtest error-2.2 {errors in nested procedures} {
X catch foo b
X set b
X} {Human-generated}
X
Xtest error-2.3 {errors in nested procedures} {
X catch foo b
X set errorInfo
X} {Human-generated
X while executing
X"error {Human-generated}"
X (procedure "foo" line 4)
X invoked from within
X"foo"}
X
Xtest error-2.4 {errors in nested procedures} {
X catch foo2 b
X} 1
X
Xtest error-2.5 {errors in nested procedures} {
X catch foo2 b
X set b
X} {Human-generated}
X
Xtest error-2.6 {errors in nested procedures} {
X catch foo2 b
X set errorInfo
X} {glorp2
X while executing
X"error glorp2"
X invoked from within
X"format [error glorp2]..."
X (procedure "foo2" line 1)
X invoked from within
X"foo2"}
X
X# Error conditions related to "catch".
X
Xtest error-3.1 {errors in catch command} {
X list [catch {catch} msg] $msg
X} {1 {wrong # args: should be "catch command ?varName?"}}
Xtest error-3.2 {errors in catch command} {
X list [catch {catch a b c} msg] $msg
X} {1 {wrong # args: should be "catch command ?varName?"}}
Xtest error-3.3 {errors in catch command} {
X catch {unset a}
X set a(0) 22
X list [catch {catch {format 44} a} msg] $msg
X} {1 {couldn't save command result in variable}}
Xcatch {unset a}
X
X# More tests related to errorInfo and errorCode
X
Xtest error-4.1 {errorInfo and errorCode variables} {
X list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode
X} {1 msg1 msg2 msg3}
Xtest error-4.2 {errorInfo and errorCode variables} {
X list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode
X} {1 msg1 {msg1
X while executing
X"error msg1 {} msg3"} msg3}
Xtest error-4.3 {errorInfo and errorCode variables} {
X list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode
X} {1 msg1 {msg1
X while executing
X"error msg1 {}"} NONE}
Xtest error-4.4 {errorInfo and errorCode variables} {
X set errorCode bogus
X list [catch {error msg1} msg] $msg $errorInfo $errorCode
X} {1 msg1 {msg1
X while executing
X"error msg1"} NONE}
Xtest error-4.5 {errorInfo and errorCode variables} {
X set errorCode bogus
X list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode
X} {1 msg1 msg2 {}}
X
X# Errors in error command itself
X
Xtest error-5.1 {errors in error command} {
X list [catch {error} msg] $msg
X} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
Xtest error-5.2 {errors in error command} {
X list [catch {error a b c d} msg] $msg
X} {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}}
X
X# Make sure that catch resets error information
X
Xtest error-6.1 {catch must reset error state} {
X catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
X list $errorCode $errorInfo
X} {NONE 1}
X
Xreturn ""
END_OF_FILE
if test 5000 -ne `wc -c <'tcl6.1/tests/error.test'`; then
echo shar: \"'tcl6.1/tests/error.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/error.test'
fi
if test -f 'tcl6.1/tests/for.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/for.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/for.test'\" $4309 characters$
sed "s/^X//" >'tcl6.1/tests/for.test' <<'END_OF_FILE'
X# Commands covered: foreach, for, continue, break

X# $Header: /sprite/src/lib/tcl/tests/RCS/for.test,v 1.7 91/07/23 21:01:05 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# Basic "foreach" operation.
X
Xtest for-1.1 {basic foreach tests} {
X set a {}
X foreach i {a b c d} {
X set a [concat $a $i]
X }
X set a

X} {a b c d}

Xtest for-1.2 {basic foreach tests} {
X set a {}
X foreach i {a b {{c d} e} {123 {{x}}}} {
X set a [concat $a $i]
X }
X set a
X} {a b {c d} e 123 {{x}}}
Xtest for-1.3 {basic foreach tests} {catch {foreach} msg} 1
Xtest for-1.4 {basic foreach tests} {
X catch {foreach} msg
X set msg
X} {wrong # args: should be "foreach varName list command"}
Xtest for-1.5 {basic foreach tests} {catch {foreach i} msg} 1
Xtest for-1.6 {basic foreach tests} {
X catch {foreach i} msg
X set msg
X} {wrong # args: should be "foreach varName list command"}
Xtest for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1
Xtest for-1.8 {basic foreach tests} {
X catch {foreach i j} msg
X set msg
X} {wrong # args: should be "foreach varName list command"}
Xtest for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1
Xtest for-1.10 {basic foreach tests} {
X catch {foreach i j k l} msg
X set msg
X} {wrong # args: should be "foreach varName list command"}
Xtest for-1.11 {basic foreach tests} {
X set a {}
X foreach i {} {
X set a [concat $a $i]
X }
X set a
X} {}
Xtest for-1.11 {foreach errors} {
X catch {unset a}
X set a(0) 44
X list [catch {foreach a {1 2 3} {}} msg] $msg
X} {1 {couldn't set loop variable}}
Xcatch {unset a}
X
X# Check "continue".
X
Xtest for-2.1 {continue tests} {catch continue} 4
Xtest for-2.2 {continue tests} {
X set a {}
X foreach i {a b c d} {
X if {[string compare $i "b"] == 0} continue
X set a [concat $a $i]
X }
X set a
X} {a c d}
Xtest for-2.3 {continue tests} {
X set a {}
X foreach i {a b c d} {
X if {[string compare $i "b"] != 0} continue
X set a [concat $a $i]
X }
X set a
X} {b}
Xtest for-2.4 {continue tests} {catch {continue foo} msg} 1
Xtest for-2.5 {continue tests} {
X catch {continue foo} msg
X set msg
X} {wrong # args: should be "continue"}
X
X# Check "break".
X
Xtest for-3.1 {break tests} {catch break} 3
Xtest for-3.2 {break tests} {
X set a {}
X foreach i {a b c d} {
X if {[string compare $i "c"] == 0} break
X set a [concat $a $i]
X }
X set a
X} {a b}
Xtest for-3.3 {break tests} {catch {break foo} msg} 1
Xtest for-3.4 {break tests} {
X catch {break foo} msg
X set msg
X} {wrong # args: should be "break"}
X
X# Check "for" and its use of continue and break.
X
Xtest for-4.1 {for tests} {
X set a {}
X for {set i 1} {$i<6} {set i [expr $i+1]} {
X set a [concat $a $i]
X }
X set a

X} {1 2 3 4 5}

Xtest for-4.2 {for tests} {
X set a {}
X for {set i 1} {$i<6} {set i [expr $i+1]} {
X if $i==4 continue
X set a [concat $a $i]
X }
X set a
X} {1 2 3 5}
Xtest for-4.3 {for tests} {
X set a {}
X for {set i 1} {$i<6} {set i [expr $i+1]} {
X if $i==4 break
X set a [concat $a $i]
X }
X set a
X} {1 2 3}
Xtest for-4.4 {for tests} {catch {for 1 2 3} msg} 1
Xtest for-4.5 {for tests} {
X catch {for 1 2 3} msg
X set msg
X} {wrong # args: should be "for start test next command"}
Xtest for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1
Xtest for-4.7 {for tests} {
X catch {for 1 2 3 4 5} msg
X set msg
X} {wrong # args: should be "for start test next command"}
Xtest for-4.8 {for tests} {
X set a {xyz}
X for {set i 1} {$i<6} {set i [expr $i+1]} {}
X set a
X} xyz
Xtest for-4.9 {for tests} {
X set a {}
X for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} {
X set a [concat $a $i]
X }
X set a
X} {1 2 3}
END_OF_FILE
if test 4309 -ne `wc -c <'tcl6.1/tests/for.test'`; then
echo shar: \"'tcl6.1/tests/for.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/for.test'
fi
if test -f 'tcl6.1/tests/glob.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/glob.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/glob.test'\" $4230 characters$
sed "s/^X//" >'tcl6.1/tests/glob.test' <<'END_OF_FILE'
X# Commands covered: glob

X# $Header: /user6/ouster/tcl/tests/RCS/glob.test,v 1.15 91/10/17 16:22:32 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# First, create some subdirectories to use for testing.
X
Xexec rm -rf globTest
Xexec mkdir globTest globTest/a1 globTest/a2 globTest/a3
Xexec mkdir globTest/a1/b1 globTest/a1/b2 globTest/a2/b3
Xexec cat << abc > globTest/x1.c
Xexec cat << abc > globTest/y1.c
Xexec cat << abc > globTest/z1.c
Xexec cat << abc > "globTest/weird name.c"
Xexec cat << abc > globTest/.1
Xexec cat << abc > globTest/a1/b1/x2.c
Xexec cat << abc > globTest/a1/b2/y2.c
X
Xtest glob-1.1 {simple globbing} {glob a} a
Xtest glob-1.2 {simple globbing} {glob aaa bbb ccc} {aaa bbb ccc}
X
Xtest glob-2.1 {globbing with braces} {glob "{a1,a2}"} "a1 a2"
Xtest glob-2.2 {globbing with braces} {glob a/{x,y}{123,456}/z} \
X "a/x123/z a/x456/z a/y123/z a/y456/z"
X
Xtest glob-3.1 {asterisks and question marks} {glob g*/*.c} \
X "globTest/x1.c globTest/y1.c globTest/z1.c {globTest/weird name.c}"
Xtest glob-3.2 {asterisks and question marks} {glob globTest/?1.c} \
X "globTest/x1.c globTest/y1.c globTest/z1.c"
Xtest glob-3.3 {asterisks and question marks} {glob */*/*/*.c} \
X "globTest/a1/b1/x2.c globTest/a1/b2/y2.c"
Xtest glob-3.4 {asterisks and question marks} {glob globTest/*} \
X "globTest/a1 globTest/a2 globTest/a3 globTest/x1.c globTest/y1.c globTest/z1.c {globTest/weird name.c}"
Xtest glob-3.5 {asterisks and question marks} {glob globTest/.*} \
X "globTest/. globTest/.. globTest/.1"
Xtest glob-3.6 {asterisks and question marks} {glob globTest/*/*} \
X "globTest/a1/b1 globTest/a1/b2 globTest/a2/b3"
Xtest glob-3.7 {asterisks and question marks} {glob {globTest/[xy]1.*}} \
X "globTest/x1.c globTest/y1.c"
X
X# The tests immediately below can only be run at Berkeley, where
X# the file-system structure is well-known.
X
Xif {[string compare [glob ~] /users/ouster] == 0} {
X test glob-4.1 {tildes} {glob ~/.csh*} "/users/ouster/.cshrc"
X test glob-4.2 {tildes} {glob ~/.csh*} "/users/ouster/.cshrc"
X}
X
Xtest glob-5.1 {error conditions} {
X list [catch {glob} msg] $msg
X} {1 {wrong # args: should be "glob ?-nocomplain? name ?name ...?"}}
Xtest glob-5.2 {error conditions} {
X list [catch {glob a/{b,c,d}/\{} msg] $msg
X} {1 {unmatched open-brace in file name}}
Xtest glob-5.3 {error conditions} {
X list [catch {glob goo/*} msg] $msg
X} {1 {no files matched glob pattern(s)}}
Xtest glob-5.4 {error conditions} {
X list [catch {glob globTest/*.c goo/*} msg] $msg
X} {0 {globTest/x1.c globTest/y1.c globTest/z1.c {globTest/weird name.c}}}
Xtest glob-5.5 {error conditions} {
X list [catch {glob ~no-one} msg] $msg
X} {1 {user "no-one" doesn't exist}}
Xtest glob-5.6 {error conditions} {

X set home $env(HOME)
X unset env(HOME)

X set x [list [catch {glob ~/*} msg] $msg]

X set env(HOME) $home
X set x

X} {1 {couldn't find HOME environment variable to expand "~/*"}}
X
Xexec chmod 000 globTest
Xif {$user != "root"} {
X test glob-6.1 {setting errorCode variable} {
X string tolower [list [catch {glob globTest/*} msg] $msg $errorCode]
X } {1 {couldn't read directory "globtest/": permission denied} {unix eacces {permission denied}}}
X}
Xexec chmod 755 globTest
X
Xtest glob-7.1 {-nocomplain option} {
X list [catch {glob -nocomplai} msg] $msg
X} {0 -nocomplai}
Xtest glob-7.2 {-nocomplain option} {
X list [catch {glob -nocomplain} msg] $msg
X} {1 {wrong # args: should be "glob ?-nocomplain? name ?name ...?"}}
Xtest glob-7.3 {-nocomplain option} {
X list [catch {glob -nocomplain goo/*} msg] $msg
X} {0 {}}
X
Xexec rm -rf globTest
END_OF_FILE
if test 4230 -ne `wc -c <'tcl6.1/tests/glob.test'`; then
echo shar: \"'tcl6.1/tests/glob.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/glob.test'
fi
if test -f 'tcl6.1/tests/if.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/if.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/if.test'\" $4547 characters$
sed "s/^X//" >'tcl6.1/tests/if.test' <<'END_OF_FILE'
X# Commands covered: if

X# $Header: /sprite/src/lib/tcl/tests/RCS/if.test,v 1.3 91/08/20 14:19:03 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest if-1.1 {taking proper branch} {
X set a {}
X if 0 {set a 1} else {set a 2}
X set a
X} 2
Xtest if-1.2 {taking proper branch} {
X set a {}
X if 1 {set a 1} else {set a 2}
X set a
X} 1
Xtest if-1.3 {taking proper branch} {
X set a {}
X if 1<2 {set a 1}
X set a
X} 1
Xtest if-1.4 {taking proper branch} {
X set a {}
X if 1>2 {set a 1}
X set a
X} {}
Xtest if-1.4 {taking proper branch} {
X set a {}
X if 1>2 {set a 1} else {}
X set a
X} {}
X
Xtest if-2.1 {optional then-else args} {
X set a 44
X if 1==3 then {set a 1} else {set a 2}
X set a
X} 2
Xtest if-2.2 {optional then-else args} {
X set a 44
X if 1!=3 then {set a 1} else {set a 2}
X set a
X} 1
Xtest if-2.3 {optional then-else args} {
X set a 44
X if 1==3 {set a 1} else {set a 2}
X set a
X} 2
Xtest if-2.4 {optional then-else args} {
X set a 44
X if 1!=3 {set a 1} else {set a 2}
X set a
X} 1
Xtest if-2.5 {optional then-else args} {
X set a 44
X if 1==3 then {set a 1} {set a 2}
X set a
X} 2
Xtest if-2.6 {optional then-else args} {
X set a 44
X if 1!=3 then {set a 1} {set a 2}
X set a
X} 1
Xtest if-2.7 {optional then-else args} {
X set a 44
X if 1==3 {set a 1} {set a 2}
X set a
X} 2
Xtest if-2.8 {optional then-else args} {
X set a 44
X if 1!=3 {set a 1} {set a 2}
X set a
X} 1
Xtest if-2.9 {optional then-else args} {
X set a 44
X if 1==3 t {set a 1} e {set a 2}
X set a
X} 2
X
Xtest if-3.1 {error conditions} {
X catch {if 2}
X} 1
Xtest if-3.2 {error conditions} {
X catch {if 2} msg
X set msg
X} {wrong # args: should be "if bool ?then? command ?else? ?command?"}
Xtest if-3.3 {error conditions} {
X catch {if 1 then}
X} 1
Xtest if-3.4 {error conditions} {
X catch {if 1 then} msg
X set msg
X} {wrong # args: should be "if bool ?then? command ?else? ?command?"}
Xtest if-3.5 {error conditions} {
X catch {if 1 {set a b} else}
X} 1
Xtest if-3.6 {error conditions} {
X catch {if 1 {set a b} else} msg
X set msg
X} {wrong # args: should be "if bool ?then? command ?else? ?command?"}
Xtest if-3.7 {error conditions} {
X catch {if {[error "error in condition"]} foo}
X} 1
Xtest if-3.8 {error conditions} {
X catch {if {[error "error in condition"]} foo} msg
X set msg
X} {error in condition}
Xtest if-3.9 {error conditions} {
X catch {if {[error "error in condition"]} foo} msg
X set errorInfo
X} {error in condition
X while executing
X"error "error in condition""
X ("if" test line 1)
X invoked from within
X"if {[error "error in condition"]} foo"}
Xtest if-3.10 {error conditions} {
X catch {if 1 then {error "error in then clause"}}
X} 1
Xtest if-3.11 {error conditions} {
X catch {if 1 then {error "error in then clause"}} msg
X set msg
X} {error in then clause}
Xtest if-3.12 {error conditions} {
X catch {if 1 then {error "error in then clause"}} msg
X set errorInfo
X} {error in then clause
X while executing
X"error "error in then clause""
X ("then" clause line 1)
X invoked from within
X"if 1 then {error "error in then clause"}"}
Xtest if-3.13 {error conditions} {
X catch {if 0 {} {error "error in else clause"}}
X} 1
Xtest if-3.14 {error conditions} {
X catch {if 0 {} {error "error in else clause"}} msg
X set msg
X} {error in else clause}
Xtest if-3.15 {error conditions} {
X catch {if 0 {} {error "error in else clause"}} msg
X set errorInfo
X} {error in else clause
X while executing
X"error "error in else clause""
X ("else" clause line 1)
X invoked from within
X"if 0 {} {error "error in else clause"}"}
X
Xtest if-4.1 {return value} {
X if 1 then {set a 22; format abc}
X} abc
Xtest if-4.2 {return value} {
X if 0 then {set a 22; format abc} else {format def}
X} def
Xtest if-4.3 {return value} {
X if 0 then {set a 22; format abc}
X} {}
END_OF_FILE
if test 4547 -ne `wc -c <'tcl6.1/tests/if.test'`; then
echo shar: \"'tcl6.1/tests/if.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/if.test'
fi
echo shar: End of archive 3 $of 33$.
cp /dev/null ark3isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:26:46 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 72
Archive-name: tcl/part04
Environment: UNIX

# "End of archive 4 (of 33)."
# Contents: tcl6.1/doc/Backslash.man tcl6.1/doc/Concat.man
# tcl6.1/doc/CrtInterp.man tcl6.1/doc/History.man
# tcl6.1/doc/TildeSubst.man tcl6.1/tclAssem.c tcl6.1/tests/exec.test
# tcl6.1/tests/upvar.test
# Wrapped by karl@one on Tue Nov 12 19:44:13 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/Backslash.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Backslash.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Backslash.man'\" $5407 characters$
sed "s/^X//" >'tcl6.1/doc/Backslash.man' <<'END_OF_FILE'

X'\" Copyright 1989 Regents of the University of California
X'\" Permission to use, copy, modify, and distribute this
X'\" documentation for any purpose and without fee is hereby
X'\" granted, provided that this notice appears in all copies.
X'\" The University of California makes no representations about

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Backslash.man,v 1.6 91/05/23 14:11:06 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_Backslash tcl
X.BS
X.SH NAME
XTcl_Backslash \- parse a backslash sequence

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xchar
X\fBTcl_Backslash\fR(\fIsrc, countPtr\fR)
X.SH ARGUMENTS
X.AP char *src in
XPointer to a string starting with a backslash.
X.AP int *countPtr out
XIf \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled
Xin with number of characters in the backslash sequence, including
Xthe backslash character.

X.BE
X
X.SH DESCRIPTION
X.PP

XThis is a utility procedure used by several of the Tcl
Xcommands. It parses a backslash sequence and returns
Xthe single character corresponding to the sequence.
X.VS
XIf the backslash sequence should be replaced by no character
Xat all (e.g. backslash-newline) then \fBTcl_Backslash\fR returns 0.
X.VE
X\fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number
Xof characters in the backslash sequence.
XIf \fIsrc\fR doesn't point to a backslash
Xsequence understood by Tcl, then Tcl_Backslash returns a backslash
Xas its result and \fI*countPtr\fR gets set to 1 (in this case the
Xbackslash character should not get any special treatment).
X.PP
XSee the Tcl manual entry for information on the valid
Xbackslash sequences.
X.VS
XAll of the sequences described in the Tcl
Xmanual entry are supported by \fBTcl_Backslash\fR.
X.VE
X
X.SH KEYWORDS
Xbackslash, parse
END_OF_FILE
if test 5407 -ne `wc -c <'tcl6.1/doc/Backslash.man'`; then
echo shar: \"'tcl6.1/doc/Backslash.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Backslash.man'
fi
if test -f 'tcl6.1/doc/Concat.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Concat.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Concat.man'\" $5457 characters$
sed "s/^X//" >'tcl6.1/doc/Concat.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Concat.man,v 1.2 91/05/29 14:45:29 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_Concat tcl
X.BS
X.SH NAME
XTcl_Concat \- concatenate a collection of strings

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xchar *
X\fBTcl_Concat\fR(\fIargc, argv\fR)
X.SH ARGUMENTS
X.AP int argc in
XNumber of strings.
X.AP char *argv[] in
XArray of strings to concatenate. Must have \fIargc\fR entries.

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_Concat\fR is a utility procedure used by several of the
XTcl commands. Given a collection of strings, it concatenates
Xthem together into a single string, with the original strings
Xseparated by spaces. This procedure behaves differently than
X\fBTcl_Merge\fR, in that the arguments are simply concatenated:
Xno effort is made to ensure proper list structure.
X.VS
XHowever, in most common usage the arguments will all be proper
Xlists themselves; if this is true, then the result will also have
Xproper list structure.
X.PP
X\fBTcl_Concat\fR eliminates leading and trailing white space as it
Xcopies strings from \fBargv\fR to the result. If an element of
X\fBargv\fR consists of nothing but white space, then that string
Xis ignored entirely. This white-space removal was added to make
Xthe output of the \fBconcat\fR command cleaner-looking.
X.VE
X.PP
XThe result string is dynamically allocated
Xusing \fBmalloc()\fR; the caller must eventually release the space
Xby calling \fBfree()\fR.
X
X.SH KEYWORDS
Xconcatenate, strings
END_OF_FILE
if test 5457 -ne `wc -c <'tcl6.1/doc/Concat.man'`; then
echo shar: \"'tcl6.1/doc/Concat.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Concat.man'
fi
if test -f 'tcl6.1/doc/CrtInterp.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/CrtInterp.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/CrtInterp.man'\" $5355 characters$
sed "s/^X//" >'tcl6.1/doc/CrtInterp.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/CrtInterp.man,v 1.3 91/07/23 21:47:05 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_CreateInterp tcl
X.BS
X.SH NAME
XTcl_CreateInterp, Tcl_DeleteInterp \- create and delete Tcl command interpreters

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

XTcl_Interp *
X\fBTcl_CreateInterp\fR()
X.sp
X\fBTcl_DeleteInterp\fR(\fIinterp\fR)
X.SH ARGUMENTS
X.AS Tcl_Interp *interp
X.AP Tcl_Interp *interp in
XToken for interpreter to be destroyed.

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_CreateInterp\fR creates a new interpreter structure and returns
Xa token for it. The token is required in calls to most other Tcl
Xprocedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and
X\fBTcl_DeleteInterp\fR.
XClients are only allowed to access a few of the fields of
XTcl_Interp structures; see the Tcl_Interp
Xand \fBTcl_CreateCommand\fR man pages for details.
XThe new interpreter is initialized with no defined variables and only
Xthe built-in Tcl commands. To bind in additional commands, call
X\fBTcl_CreateCommand\fR.
X.PP
X\fBTcl_DeleteInterp\fR destroys a command interpreter and releases all of
Xthe resources associated with it, including variables, procedures,
Xand application-specific command bindings. After \fBTcl_DeleteInterp\fR
Xreturns the caller should never again use the \fIinterp\fR token.
X
X.SH KEYWORDS
Xcommand, create, delete, interpreter
END_OF_FILE
if test 5355 -ne `wc -c <'tcl6.1/doc/CrtInterp.man'`; then
echo shar: \"'tcl6.1/doc/CrtInterp.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/CrtInterp.man'
fi
if test -f 'tcl6.1/doc/History.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/History.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/History.man'\" $6235 characters$
sed "s/^X//" >'tcl6.1/doc/History.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/History.man,v 1.3 91/10/27 14:29:31 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_InitHistory tcl
X.BS
X.SH NAME
XTcl_InitHistory, Tcl_RecordAndEval \- procedures for managing history list

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

X.VS
X\fBTcl_InitHistory\fR(\fIinterp\fR)
X.VE
X.sp
Xint
X\fBTcl_RecordAndEval\fR(\fIinterp, cmd, flags\fR)
X.SH ARGUMENTS
X.AS Tcl_Interp *interp;
X.AP Tcl_Interp *interp in
XTcl interpreter in which history facilities are being used.
X.AP char *cmd in
XCommand (or sequence of commands) to execute.
X.AP char flags in
XFlags to pass to \fBTcl_Eval\fR (normally 0). If -1, then the
Xcommand is not executed; it's just recorded.

X.BE
X
X.SH DESCRIPTION
X.PP

XThe procedure \fBTcl_HistoryInit\fR is invoked to enable the
X.VS
Xhistory facilities in an interpreter (by default there is no
X\fBhistory\fR command in an interpreter).
XAfter this command has been executed the \fBhistory\fR
Xcommand will be available in \fIinterp\fR and the history facilities
Xwill be initialized.
X\fBTcl_HistoryInit\fR is invoked automatically by
X\fBTcl_RecordAndEval\fR, so it need not be invoked explicitly
Xunless the \fBhistory\fR command is to
Xbe used before \fBTcl_RecordAndEval\fR has been called.
X.VE
X.PP
X\fBTcl_RecordAndEval\fR is invoked to record a command on the history
Xlist and then execute it. Programs that do not wish to use the history
Xmechanism should not call \fBTcl_RecordAndEval\fR; they should call
X\fBTcl_Eval\fR instead. Furthermore, \fBTcl_RecordAndEval\fR should
Xonly be called with top-level commands typed by the user, since the
Xpurpose of history is to allow the user to re-issue recently-invoked
Xcommands.
X.PP
X\fBTcl_RecordAndEval\fR does three things.
XFirst, it calls \fBTcl_HistoryInit\fR to initialize history for the
Xinterpreter \fIinterp\fR, if this hasn't already been done.
XSecond, \fBTcl_RecordAndEval\fR saves \fIcommand\fR in
Xthe history list for \fIinterp\fR, making a new event to hold the
Xcommand.
XThird, \fBTcl_RecordAndEval\fR executes the command by passing it
Xand \fIflags\fR to \fBTcl_Eval\fR. If \fIflags\fR is -1 then only
Xthe first two steps are taken; the command will not be executed.
X
X.SH KEYWORDS
Xcommand, event, execute, history, interpreter, record
END_OF_FILE
if test 6235 -ne `wc -c <'tcl6.1/doc/History.man'`; then
echo shar: \"'tcl6.1/doc/History.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/History.man'
fi
if test -f 'tcl6.1/doc/TildeSubst.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/TildeSubst.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/TildeSubst.man'\" $5835 characters$
sed "s/^X//" >'tcl6.1/doc/TildeSubst.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/TildeSubst.man,v 1.3 91/04/03 15:14:15 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_TildeSubst tcl
X.BS
X.SH NAME
XTcl_TildeSubst \- replace tilde with home directory in a file name

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xchar *
X\Tcl_TildeSubst\fR(\fIinterp\fR, \fIname\fR)
X.SH ARGUMENTS
X.AP Tcl_Interp *interp in
XInterpreter in which to report an error, if any.
X.AP char *name in
XFile name, which may start with a ``~''.

X.BE
X
X.SH DESCRIPTION
X.PP

XThis utility procedure does tilde substition. If \fIname\fR doesn't
Xstart with a ``~'' character, then the procedure returns \fIname\fR.
XIf \fIname\fR does start with a tilde, then \fBTcl_TildeSubst\fR
Xreturns a new string identical to \fIname\fR except that the first
Xelement of \fIname\fR is replaced with the location of the home
Xdirectory for the given user. The substitution is carried out in
Xthe same way that it would be done by \fIcsh\fR. If the tilde is
Xfollowed immediately by a slash, then the \fB$HOME\fR environment
Xvariable is substituted. Otherwise the characters between the
Xtilde and the next slash are taken as a user name, which is
Xlooked up in the password file; the user's home directory is
Xretrieved from the password file and substituted.
X.PP
XThe string returned by \fBTcl_TildeSubst\fR is a static string
Xbelonging to \fBTcl_TildeSubst\fR. Its value will only persist
Xuntil the next call to \fBTcl_TildeSubst\fR; the caller should
Xmake a copy of the result if it needs to live a long time.
X.PP
XIf an error occurs (e.g. because there was no user by the given
Xname) then NULL is returned and an error message will be left
Xat \fIinterp->result\fR. It is assumed that \fIinterp->result\fR
Xhas been initialized in the standard way when \fBTcl_TildeSubst\fR
Xis invoked.
X
X.SH KEYWORDS
Xfile name, home directory, tilde, user
END_OF_FILE
if test 5835 -ne `wc -c <'tcl6.1/doc/TildeSubst.man'`; then
echo shar: \"'tcl6.1/doc/TildeSubst.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/TildeSubst.man'
fi
if test -f 'tcl6.1/tclAssem.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclAssem.c'\"
else
echo shar: Extracting \"'tcl6.1/tclAssem.c'\" $5788 characters$
sed "s/^X//" >'tcl6.1/tclAssem.c' <<'END_OF_FILE'
X/*
X * tclAssem.c --
X *
X * This file contains procedures to help assemble Tcl commands
X * from an input source where commands may arrive in pieces, e.g.
X * several lines of type-in corresponding to one command.
X *
X * Copyright 1990-1991 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/tclAssem.c,v 1.8 91/09/23 11:22:22 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X
X/*
X * The structure below is the internal representation for a command
X * buffer, which is used to hold a piece of a command until a full
X * command is available. When a full command is available, it will
X * be returned to the user, but it will also be retained in the buffer
X * until the NEXT call to Tcl_AssembleCmd, at which point it will be
X * removed.
X */
X
Xtypedef struct {
X char *buffer; /* Storage for command being assembled.
X * Malloc-ed, and grows as needed. */
X int bufSize; /* Total number of bytes in buffer. */
X int bytesUsed; /* Number of bytes in buffer currently
X * occupied (0 means there is not a
X * buffered incomplete command). */
X} CmdBuf;
X
X/*
X * Default amount of space to allocate in command buffer:
X */
X
X#define CMD_BUF_SIZE 100

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CreateCmdBuf --
X *
X * Allocate and initialize a command buffer.

X *
X * Results:

X * The return value is a token that may be passed to
X * Tcl_AssembleCmd and Tcl_DeleteCmdBuf.

X *
X * Side effects:

X * Memory is allocated.

X *
X *----------------------------------------------------------------------
X */
X

XTcl_CmdBuf
XTcl_CreateCmdBuf()
X{
X register CmdBuf *cbPtr;
X
X cbPtr = (CmdBuf *) ckalloc(sizeof(CmdBuf));
X cbPtr->buffer = (char *) ckalloc(CMD_BUF_SIZE);
X cbPtr->bufSize = CMD_BUF_SIZE;
X cbPtr->bytesUsed = 0;
X return (Tcl_CmdBuf) cbPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DeleteCmdBuf --
X *
X * Release all of the resources associated with a command buffer.
X * The caller should never again use buffer again.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Memory is released.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DeleteCmdBuf(buffer)
X Tcl_CmdBuf buffer; /* Token for command buffer (return value
X * from previous call to Tcl_CreateCmdBuf). */
X{
X register CmdBuf *cbPtr = (CmdBuf *) buffer;
X
X ckfree(cbPtr->buffer);
X ckfree((char *) cbPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_AssembleCmd --
X *
X * This is a utility procedure to assist in situations where
X * commands may be read piece-meal from some input source. Given
X * some input text, it adds the text to an input buffer and returns
X * whole commands when they are ready.

X *
X * Results:

X * If the addition of string to any currently-buffered information
X * results in one or more complete Tcl commands, then the return value
X * is a pointer to the complete command(s). The command value will
X * only be valid until the next call to this procedure with the
X * same buffer. If the addition of string leaves an incomplete
X * command at the end of the buffer, then NULL is returned.

X *
X * Side effects:

X * If string leaves a command incomplete, the partial command
X * information is buffered for use in later calls to this procedure.
X * Once a command has been returned, that command is deleted from
X * the buffer on the next call to this procedure.

X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_AssembleCmd(buffer, string)
X Tcl_CmdBuf buffer; /* Token for a command buffer previously
X * created by Tcl_CreateCmdBuf. */
X char *string; /* Bytes to be appended to command stream.
X * Note: if the string is zero length,
X * then whatever is buffered will be
X * considered to be a complete command
X * regardless of whether parentheses are
X * matched or not. */
X{
X register CmdBuf *cbPtr = (CmdBuf *) buffer;
X int length, totalLength;

X register char *p;
X

X /*
X * If an empty string is passed in, just pretend the current
X * command is complete, whether it really is or not.
X */
X
X length = strlen(string);
X if (length == 0) {
X cbPtr->bytesUsed = 0;
X return cbPtr->buffer;
X }
X
X /*
X * Add the new information to the buffer. If the current buffer
X * isn't large enough, grow it by at least a factor of two, or
X * enough to hold the new text.
X */
X
X length = strlen(string);
X totalLength = cbPtr->bytesUsed + length + 1;
X if (totalLength > cbPtr->bufSize) {
X unsigned int newSize;
X char *newBuf;
X
X newSize = cbPtr->bufSize*2;
X if (newSize < totalLength) {
X newSize = totalLength;
X }
X newBuf = (char *) ckalloc(newSize);
X strcpy(newBuf, cbPtr->buffer);
X ckfree(cbPtr->buffer);
X cbPtr->buffer = newBuf;
X cbPtr->bufSize = newSize;
X }
X strcpy(cbPtr->buffer+cbPtr->bytesUsed, string);
X cbPtr->bytesUsed += length;
X
X /*
X * See if there is now a complete command in the buffer.
X */
X
X p = cbPtr->buffer;
X while (1) {
X int gotNewLine = 0;
X
X while (isspace(*p)) {
X if (*p == '\n') {
X gotNewLine = 1;
X }
X p++;
X }
X if (*p == 0) {
X if (gotNewLine) {
X cbPtr->bytesUsed = 0;
X return cbPtr->buffer;
X }
X return NULL;
X }
X p = TclWordEnd(p, 0);
X }
X}
END_OF_FILE
if test 5788 -ne `wc -c <'tcl6.1/tclAssem.c'`; then
echo shar: \"'tcl6.1/tclAssem.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclAssem.c'
fi
if test -f 'tcl6.1/tests/exec.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/exec.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/exec.test'\" $6291 characters$
sed "s/^X//" >'tcl6.1/tests/exec.test' <<'END_OF_FILE'
X# Commands covered: exec

X# $Header: /sprite/src/lib/tcl/tests/RCS/exec.test,v 1.16 91/09/11 17:29:55 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# Basic operations.
X
Xtest exec-1.1 {basic exec operation} {
X exec echo a b c
X} "a b c"
Xtest exec-1.2 {pipelining} {
X exec echo a b c d | cat | cat

X} "a b c d"

Xtest exec-1.3 {pipelining} {
X set a [exec echo a b c d | cat | wc]
X list [scan $a "%d %d %d" b c d] $b $c $d
X} {3 1 4 8}
X
X# I/O redirection: input from Tcl command.
X
Xtest exec-2.1 {redirecting input from immediate source} {
X exec cat << "Sample text"
X} {Sample text}
Xtest exec-2.2 {redirecting input from immediate source} {
X exec << "Sample text" cat | cat
X} {Sample text}
Xtest exec-2.3 {redirecting input from immediate source} {
X exec cat << "Sample text" | cat
X} {Sample text}
Xtest exec-2.4 {redirecting input from immediate source} {
X exec cat | cat << "Sample text"
X} {Sample text}
X
X# I/O redirection: output to file.
X
Xcatch [exec rm -f gorp.file]
Xtest exec-3.1 {redirecting output to file} {
X exec echo "Some simple words" > gorp.file
X exec cat gorp.file
X} "Some simple words"
Xtest exec-3.2 {redirecting output to file} {
X exec echo "More simple words" | > gorp.file cat | cat
X exec cat gorp.file
X} "More simple words"
Xtest exec-3.3 {redirecting output to file} {
X exec > gorp.file echo "Different simple words" | cat | cat
X exec cat gorp.file
X} "Different simple words"
X
X# I/O redirection: input from file.
X
Xexec echo "Just a few thoughts" > gorp.file
Xtest exec-4.1 {redirecting input from file} {
X exec cat < gorp.file
X} {Just a few thoughts}
Xtest exec-4.2 {redirecting input from file} {
X exec cat | cat < gorp.file
X} {Just a few thoughts}
Xtest exec-4.3 {redirecting input from file} {
X exec cat < gorp.file | cat
X} {Just a few thoughts}
Xtest exec-4.4 {redirecting input from file} {
X exec < gorp.file cat | cat
X} {Just a few thoughts}
X
X# I/O redirection: combinations.
X
Xcatch {exec rm -f gorp.file2}
Xtest exec-5.1 {multiple I/O redirections} {
X exec << "command input" > gorp.file2 cat < gorp.file
X exec cat gorp.file2
X} {Just a few thoughts}
Xtest exec-5.2 {multiple I/O redirections} {
X exec < gorp.file << "command input" cat
X} {command input}
X
X# Long input to command and output from command.
X
Xset a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
Xset a [concat $a $a $a $a]
Xset a [concat $a $a $a $a]
Xset a [concat $a $a $a $a]
Xset a [concat $a $a $a $a]
Xtest exec-6.1 {long input and output} {
X exec cat << $a
X} $a
X
X# Commands that return errors.
X
Xtest exec-7.1 {commands returning errors} {
X set x [catch {exec gorp} msg]
X list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end]
X} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1}
Xtest exec-7.2 {commands returning errors} {
X set x [catch {exec foo | gorp} msg]
X set x1 {couldn't find "foo" to execute
Xcouldn't find "gorp" to execute}
X set x2 {couldn't find "gorp" to execute
Xcouldn't find "foo" to execute}
X set y [expr {($msg == $x1) || ($msg == $x2)}]
X list $x $y [lindex $errorCode 0] [lrange $errorCode 2 end]
X} {1 1 CHILDSTATUS 1}
Xtest exec-7.3 {commands returning errors} {
X list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg
X} {1 {}}
Xtest exec-7.4 {commands returning errors} {
X list [catch {exec gorp | echo a b c} msg] $msg
X} {1 {a b c
Xcouldn't find "gorp" to execute}}
X
X# Errors in executing the Tcl command, as opposed to errors in the
X# processes that are invoked.
X
Xtest exec-8.1 {errors in exec invocation} {
X list [catch {exec} msg] $msg
X} {1 {didn't specify command to execute}}
Xtest exec-8.2 {errors in exec invocation} {
X list [catch {exec | cat} msg] $msg
X} {1 {illegal use of | in command}}
Xtest exec-8.3 {errors in exec invocation} {
X list [catch {exec cat |} msg] $msg
X} {1 {illegal use of | in command}}
Xtest exec-8.4 {errors in exec invocation} {
X list [catch {exec cat | | cat} msg] $msg
X} {1 {illegal use of | in command}}
Xtest exec-8.5 {errors in exec invocation} {
X list [catch {exec cat <} msg] $msg
X} {1 {can't specify "<" as last word in command}}
Xtest exec-8.6 {errors in exec invocation} {
X list [catch {exec cat >} msg] $msg
X} {1 {can't specify ">" as last word in command}}
Xtest exec-8.7 {errors in exec invocation} {
X list [catch {exec cat <<} msg] $msg
X} {1 {can't specify "<<" as last word in command}}
Xtest exec-8.8 {errors in exec invocation} {
X list [catch {exec cat < a/b/c} msg] [string tolower $msg]
X} {1 {couldn't read file "a/b/c": no such file or directory}}
Xtest exec-8.9 {errors in exec invocation} {
X list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
X} {1 {couldn't write file "a/b/c": no such file or directory}}
X
X# Commands in background.
X
Xtest exec-9.1 {commands in background} {
X set x [lindex [time {exec sleep 5 &}] 0]
X expr $x<1000000
X} 1
Xtest exec-9.2 {commands in background} {
X list [catch {exec echo a &b} msg] $msg
X} {0 {a &b}}
X
X# Make sure "errorCode" is set correctly.
X
Xtest exec-10.1 {setting errorCode variable} {
X list [catch {exec cat < a/b/c} msg] [string tolower $errorCode]
X} {1 {unix enoent {no such file or directory}}}
Xtest exec-10.2 {setting errorCode variable} {
X list [catch {exec cat > a/b/c} msg] [string tolower $errorCode]
X} {1 {unix enoent {no such file or directory}}}
Xtest exec-10.3 {setting errorCode variable} {
X set x [catch {exec _weirdo_command_} msg]
X list $x $msg [lindex $errorCode 0] [lrange $errorCode 2 end]
X} {1 {couldn't find "_weirdo_command_" to execute} CHILDSTATUS 1}
X
Xcatch {exec rm -f gorp.file}
Xcatch {exec rm -f gorp.file2}
Xreturn {}
END_OF_FILE
if test 6291 -ne `wc -c <'tcl6.1/tests/exec.test'`; then
echo shar: \"'tcl6.1/tests/exec.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/exec.test'
fi
if test -f 'tcl6.1/tests/upvar.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/upvar.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/upvar.test'\" $5410 characters$
sed "s/^X//" >'tcl6.1/tests/upvar.test' <<'END_OF_FILE'
X# Commands covered: upvar

X# $Header: /sprite/src/lib/tcl/tests/RCS/upvar.test,v 1.1 91/10/03 16:47:56 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest upvar-1.1 {reading variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2}
X proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
X p1 foo bar
X} {foo bar 22 33 abc}
Xtest upvar-1.2 {reading variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2}
X proc p2 {} {p3}
X proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
X p1 foo bar
X} {foo bar 22 33 abc}
Xtest upvar-1.3 {reading variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2}
X proc p2 {} {p3}
X proc p3 {} {
X upvar #1 a x1 b x2 c x3 d x4
X set a abc
X list $x1 $x2 $x3 $x4 $a
X }
X p1 foo bar
X} {foo bar 22 33 abc}
Xtest upvar-1.4 {reading variables with upvar} {
X set x1 44
X set x2 55
X proc p1 {} {p2}
X proc p2 {} {
X upvar 2 x1 x1 x2 a
X upvar #0 x1 b
X set c $b
X incr b 3
X list $x1 $a $b
X }
X p1
X} {47 55 47}
X
Xtest upvar-2.1 {writing variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
X proc p2 {} {
X upvar a x1 b x2 c x3 d x4
X set x1 14
X set x4 88
X }
X p1 foo bar
X} {14 bar 22 88}
Xtest upvar-2.2 {writing variables with upvar} {
X set x1 44
X set x2 55
X proc p1 {x1 x2} {
X upvar #0 x1 a
X upvar x2 b
X set a $x1
X set b $x2
X }
X p1 newbits morebits
X list $x1 $x2
X} {newbits morebits}
Xtest upvar-2.3 {writing variables with upvar} {
X catch {unset x1}
X catch {unset x2}
X proc p1 {x1 x2} {
X upvar #0 x1 a
X upvar x2 b
X set a $x1
X set b $x2
X }
X p1 newbits morebits
X list [catch {set x1} msg] $msg [catch {set x2} msg] $msg
X} {0 newbits 0 morebits}
X
Xtest upvar-3.1 {unsetting variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
X proc p2 {} {
X upvar 1 a x1 d x2
X unset x1 x2
X }
X p1 foo bar
X} {b c}
Xtest upvar-3.2 {unsetting variables with upvar} {
X proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]}
X proc p2 {} {
X upvar 1 a x1 d x2
X unset x1 x2
X set x2 28
X }
X p1 foo bar
X} {b c d}
Xtest upvar-3.3 {unsetting variables with upvar} {
X set x1 44
X set x2 55
X proc p1 {} {p2}
X proc p2 {} {
X upvar 2 x1 a
X upvar #0 x2 b
X unset a b
X }
X p1
X list [info exists x1] [info exists x2]
X} {0 0}
Xtest upvar-3.4 {unsetting variables with upvar} {
X set x1 44
X set x2 55
X proc p1 {} {
X upvar x1 a x2 b
X unset a b
X set b 118
X }
X p1
X list [info exists x1] [catch {set x2} msg] $msg
X} {0 0 118}
X
Xtest upvar-4.1 {nested upvars} {
X set x1 88
X proc p1 {a b} {set c 22; set d 33; p2}
X proc p2 {} {global x1; upvar c x2; p3}
X proc p3 {} {
X upvar x1 a x2 b
X list $a $b
X }
X p1 14 15
X} {88 22}
Xtest upvar-4.2 {nested upvars} {
X set x1 88
X proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d}
X proc p2 {} {global x1; upvar c x2; p3}
X proc p3 {} {
X upvar x1 a x2 b
X set a foo
X set b bar
X }
X list [p1 14 15] $x1
X} {{14 15 bar 33} foo}
X
Xproc tproc {args} {global x; set x [list $args [uplevel info vars]]}
Xtest upvar-5.1 {traces involving upvars} {
X proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
X proc p2 {} {upvar c x1; set x1 22}
X set x ---
X p1 foo bar
X set x
X} {{x1 {} w} x1}
Xtest upvar-5.2 {traces involving upvars} {
X proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2}
X proc p2 {} {upvar c x1; set x1}
X set x ---
X p1 foo bar
X set x
X} {{x1 {} r} x1}
Xtest upvar-5.3 {traces involving upvars} {
X proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2}
X proc p2 {} {upvar c x1; unset x1}
X set x ---
X p1 foo bar
X set x
X} {{x1 {} u} x1}
X
Xtest upvar-6.1 {errors in upvar command} {
X list [catch upvar msg] $msg
X} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
Xtest upvar-6.2 {errors in upvar command} {
X list [catch {upvar 1} msg] $msg
X} {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}}
Xtest upvar-6.3 {errors in upvar command} {
X list [catch {upvar a b} msg] $msg

X} {1 {already at top level}}

Xtest upvar-6.4 {errors in upvar command} {
X list [catch {upvar 1 a b} msg] $msg

X} {1 {already at top level}}

Xtest upvar-6.5 {errors in upvar command} {
X list [catch {upvar #0 a b} msg] $msg

X} {1 {already at top level}}

Xtest upvar-6.6 {errors in upvar command} {
X proc p1 {} {upvar a b c}
X list [catch p1 msg] $msg
X} {1 {wrong # args: should be "a ?level? otherVar localVar ?otherVar localVar ...?"}}
Xtest upvar-6.7 {errors in upvar command} {
X proc p1 {} {set a 33; upvar b a}
X list [catch p1 msg] $msg
X} {1 {variable "a" already exists}}
END_OF_FILE
if test 5410 -ne `wc -c <'tcl6.1/tests/upvar.test'`; then
echo shar: \"'tcl6.1/tests/upvar.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/upvar.test'
fi
echo shar: End of archive 4 $of 33$.
cp /dev/null ark4isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:27:16 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 73
Archive-name: tcl/part05
Environment: UNIX

# "End of archive 5 (of 33)."
# Contents: tcl6.1/doc/AssembCmd.man tcl6.1/doc/CrtPipelin.man
# tcl6.1/doc/Eval.man tcl6.1/doc/ExprLong.man tcl6.1/doc/GetInt.man
# tcl6.1/tclUnix.h
# Wrapped by karl@one on Tue Nov 12 19:44:14 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/AssembCmd.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/AssembCmd.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/AssembCmd.man'\" $6500 characters$
sed "s/^X//" >'tcl6.1/doc/AssembCmd.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /sprite/src/lib/tcl/RCS/Tcl_AssembleCmd.man,v 1.1 90/03/11 10:30:28 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_AssembleCmd tcl
X.BS
X.SH NAME
XTcl_CreateCmdBuf, Tcl_AssembleCmd, Tcl_DeleteCmdBuf \- buffer pieces of Tcl commands

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

XTcl_CmdBuf
X\fBTcl_CreateCmdBuf\fR()
X.sp
X\fBTcl_DeleteCmdBuf\fR(\fIbuffer\fR)
X.sp
Xchar *
X\fBTcl_AssembleCmd\fR(\fIbuffer\fR, \fIstring\fR)
X.SH ARGUMENTS
X.AS Tcl_CmdBuf *string;
X.AP Tcl_CmdBuf buffer in
XToken for a command buffer (the result of some previous call to
X\fBTcl_CreateCmdBuf\fR).
X.AP char *string in
XAdditional piece of command input to be added to anything currently
Xbuffered.

X.BE
X
X.SH DESCRIPTION
X.PP

XThese three procedures provide a convenient mechanism for assembling
XTcl commands from an input source where command boundaries are not
Xobvious. For example, if input is being read from a terminal, a user
Xmay type commands that span multiple lines. In situations like
Xthis, \fBTcl_AssembleCmd\fR can be called with the individual lines
Xas they are received. It buffers the lines internally and returns
Xfull commands when they are complete.
X.PP
XA command buffer is created by calling \fBTcl_CreateCmdBuf\fR, and
Xit is deleted by calling \fBTcl_DeleteCmdBuf\fR. There may be any
Xnumber of command buffers for a particular program or even for a
Xparticular interpreter; in most cases there should be one
Xbuffer for each independent source of command input.
X.PP
XWhen input arrives from a source you should call \fBTcl_AssembleCmd\fR,
Xpassing it the new input as the \fIstring\fR argument.
X\fBTcl_AssembleCmd\fR will add the new input to anything currently
Xbuffered in \fIbuffer\fR. If the information now buffered represents
Xa complete Tcl command (i.e. the whole command ends with a newline
Xcharacter and there are no unmatched quotes, braces, or brackets),
Xthen \fBTcl_AssembleCmd\fR returns a pointer to the complete command
Xand arranges for the buffer to be cleared on the next call to
X\fBTcl_AssembleCmd\fR. If the command is still incomplete (because,
Xfor example, there are unmatched braces) then \fBTcl_AssembleCmd\fR
Xreturns NULL. \fBTcl_AssembleCmd\fR keeps a private copy of the
Xcommand being assembled, so that the caller need not preserve the
Xcontents of \fIstring\fR between calls to \fBTcl_AssembleCmd\fR.
X\fBTcl_AssembleCmd\fR supports commands of arbitrary length (up to
Xthe total memory limit imposed by the operating system, if any).
X
X.SH KEYWORDS
Xassemble, buffer, partial command
END_OF_FILE
if test 6500 -ne `wc -c <'tcl6.1/doc/AssembCmd.man'`; then
echo shar: \"'tcl6.1/doc/AssembCmd.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/AssembCmd.man'
fi
if test -f 'tcl6.1/doc/CrtPipelin.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/CrtPipelin.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/CrtPipelin.man'\" $8122 characters$
sed "s/^X//" >'tcl6.1/doc/CrtPipelin.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/CrtPipelin.man,v 1.1 91/07/20 11:21:26 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_CreatePipeline tcl
X.VS
X.BS
X.SH NAME
XTcl_CreatePipeline \- create one or more child processes, with I/O redirection

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xint
X\fBTcl_CreatePipeline\fR(\fIinterp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr\fR)
X.SH ARGUMENTS
X.AS Tcl_Interp **pidArrayPtr
X.AP Tcl_Interp *interp in
XInterpreter to use for error reporting.
X.AP int argc in
XNumber of strings in \fIargv\fR array.
X.AP char **argv in
XArray of strings describing command(s) and I/O redirection.
X.AP int **pidArrayPtr out
XThe value at \fI*pidArrayPtr\fR is modified to hold a pointer to
Xan array of process identifiers. The array is dynamically
Xallocated and must be freed by the caller.
X.AP char *inPipePtr out
XIf this argument is NULL then standard input for the first command
Xin the pipeline comes from the current standard input.
XIf \fIinPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will
Xcreate a pipe, arrange for it to be used for standard input
Xto the first command,
Xand store a file id for writing to that pipe at \fI*inPipePtr\fR.
XIf the command specified its own input using redirection, then
Xno pipe is created and -1 is stored at \fI*inPipePtr\fR.
X.AP char *outPipePtr out
XIf this argument is NULL then standard output for the last command
Xin the pipeline goes to the current standard output.
XIf \fIoutPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will
Xcreate a pipe, arrange for it to be used for standard output from
Xthe last command, and store a file id for reading from that
Xpipe at \fI*outPipePtr\fR.
XIf the command specified its own output using redirection then
Xno pipe is created and -1 is stored at \fI*outPipePtr\fR.
X.AP char *errFilePtr out
XIf this argument is NULL then error output for all the commands
Xin the pipeline will go to the current standard error file.
XIf \fIerrFilePtr\fR is not NULL, error output from all the commands
Xin the pipeline will go to a temporary file created by
X\fBTcl_CreatePipeline\fR.
XA file id to read from that file will be stored at \fI*errFilePtr\fR.
XThe file will already have been removed, so closing the file
Xdescriptor at \fI*errFilePtr\fR will cause the file to be flushed
Xcompletely.

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_CreatePipeline\fR processes the \fIargv\fR array and sets
Xup one or more child processes in a pipeline configuration.
X\fBTcl_CreatePipeline\fR handles pipes specified with ``|'',
Xinput redirection specified with ``<'' or ``<<'', and output
Xredirection specified with ``>''; see the documentation for
Xthe \fBexec\fR command for details on these specifications.
XThe return value from \fBTcl_CreatePipeline\fR is a count of
Xthe number of child processes created; the process identifiers
Xfor those processes are stored in a \fImalloc\fR-ed array and
Xa pointer to that array is stored at \fI*pidArrayPtr\fR.
XIt is the caller's responsibility to free the array when finished
Xwith it.
X.PP
XIf the \fIinPipePtr\fR, \fIoutPipePtr\fR, and \fIerrFilePtr\fR
Xarguments are NULL then the pipeline's standard input, standard
Xoutput, and standard error are taken from the corresponding
Xstreams of the process. Non-NULL values may be specified for
Xthese arguments to use pipes for standard input and standard
Xoutput and a file for standard error. \fBTcl_CreatePipeline\fR
Xwill create the requested pipes or file and return file identifiers
Xthat may be used to read or write them. It is the caller's
Xresponsibility to close all of these files when they are no
Xlonger needed. If \fIargv\fR specifies redirection for standard
Xinput or standard output, then pipes will not be created even
Xif requested by the \fIinPipePtr\fR and \fIoutPipePtr\fR
Xarguments.
X.PP
XIf an error occurs in \fBTcl_CreatePipeline\fR (e.g. ``|'' or
X``<'' was the last argument in \fIargv\fR, or it wasn't possible
Xto fork off a child), then -1 is returned
Xand \fIinterp->result\fR is set to an error message.
X
X.SH "SEE ALSO"
X\fBTcl_WaitPids\fR, \fBTcl_DetachPids\fR
X
X.SH KEYWORDS
Xbackground, child, detach, fork, process, status, wait
X.VE
END_OF_FILE
if test 8122 -ne `wc -c <'tcl6.1/doc/CrtPipelin.man'`; then
echo shar: \"'tcl6.1/doc/CrtPipelin.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/CrtPipelin.man'
fi
if test -f 'tcl6.1/doc/Eval.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Eval.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Eval.man'\" $8197 characters$
sed "s/^X//" >'tcl6.1/doc/Eval.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Eval.man,v 1.6 91/10/24 16:23:51 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_Eval tcl
X.BS
X.SH NAME
XTcl_Eval, Tcl_VarEval, Tcl_EvalFile \- execute Tcl commands

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xint
X\fBTcl_Eval\fR(\fIinterp, cmd, flags, termPtr\fR)
X.sp
Xint
X\fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR)
X.sp
Xint
X\fBTcl_EvalFile\fR(\fIinterp, fileName\fR)
X.SH ARGUMENTS
X.AS Tcl_Interp **termPtr;
X.AP Tcl_Interp *interp in
XInterpreter in which to execute the command. String result will be
Xstored in \fIinterp->result\fR.

X.AP char *cmd in
XCommand (or sequence of commands) to execute.

X.AP int flags in
XEither \fBTCL_BRACKET_TERM\fR or 0.
XIf 0, then \fBTcl_Eval\fR will process commands from \fIcmd\fR until
Xit reaches the null character at the end of the string.
XIf \fBTCL_BRACKET_TERM\fR,
Xthen \fBTcl_Eval\fR will process comands from \fIcmd\fR until either it
Xreaches a null character or it encounters a close bracket that isn't
Xbackslashed or enclosed in braces, at which point it will return.
XUnder normal conditions, \fIflags\fR should be 0.
X.AP char **termPtr out
XIf \fItermPtr\fR is non-NULL, \fBTcl_Eval\fR fills in *\fItermPtr\fR with
Xthe address of the character just after the last one in the last command
Xsuccessfully executed (normally the null character at the end of \fIcmd\fR).
XIf an error occurs in the first command in \fIcmd\fR, then \fI*termPtr\fR
Xwill be set to \fIcmd\fR.
X.AP char *string in
XString forming part of Tcl command.
X.AP char *fileName in
XName of file containing Tcl command string.

X.BE
X
X.SH DESCRIPTION
X.PP

XAll three of these procedures execute Tcl commands.
X\fBTcl_Eval\fR is the core procedure: it parses commands
Xfrom \fIcmd\fR and executes them in
Xorder until either an error occurs or \fBTcl_Eval\fR reaches a terminating
Xcharacter (']' or '\e0', depending on the value of \fIflags\fR).
XThe return value from \fBTcl_Eval\fR is one
Xof the Tcl return codes \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
X\fBTCL_CONTINUE\fR, and \fIinterp->result\fR will point to
Xa string with additional information (result value or error message).
XThis return information corresponds to the last command executed from
X\fIcmd\fR.
X.PP
X\fBTcl_VarEval\fR takes any number of string arguments
Xof any length, concatenates
Xthem into a single string, then calls \fBTcl_Eval\fR to
Xexecute that string as a Tcl command.
XIt returns the result of the command and also modifies
X\fIinterp->result\fR in the usual fashion for Tcl commands. The
Xlast argument to \fBTcl_VarEval\fR must be NULL to indicate the end
Xof arguments.
X.PP
X\fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates
Xits contents as a Tcl command by calling \fBTcl_Eval\fR. It returns
Xa standard Tcl result that reflects the result of evaluating the
Xfile.
XIf the file couldn't be read then a Tcl error is returned to describe
Xwhy the file couldn't be read.
X.PP
XDuring the processing of a Tcl command it is legal to make nested
Xcalls to evaluate other commands (this is how conditionals, loops,
Xand procedures are implemented).
XIf a code other than
X\fBTCL_OK\fR is returned from a nested \fBTcl_Eval\fR invocation, then the
Xcaller should normally return immediately, passing that same
Xreturn code back to its caller, and so on until the top-level application is
Xreached. A few commands, like \fBfor\fR, will check for certain
Xreturn codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them
Xspecially without returning.
X.PP
X\fBTcl_Eval\fR keeps track of how many nested Tcl_Eval invocations are
Xin progress for \fIinterp\fR.
XIf a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is
Xabout to be returned from the topmost \fBTcl_Eval\fR invocation for
X\fIinterp\fR, then \fBTcl_Eval\fR converts the return code to \fBTCL_ERROR\fR
Xand sets \fIinterp->result\fR to point to an error message indicating that
Xthe \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was
Xinvoked in an inappropriate place. This means that top-level
Xapplications should never see a return code from \fBTcl_Eval\fR other then
X\fBTCL_OK\fR or \fBTCL_ERROR\fR.
X
X.SH KEYWORDS
Xcommand, execute, file, interpreter
END_OF_FILE
if test 8197 -ne `wc -c <'tcl6.1/doc/Eval.man'`; then
echo shar: \"'tcl6.1/doc/Eval.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Eval.man'
fi
if test -f 'tcl6.1/doc/ExprLong.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/ExprLong.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/ExprLong.man'\" $7263 characters$
sed "s/^X//" >'tcl6.1/doc/ExprLong.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/ExprLong.man,v 1.2 91/05/31 11:52:56 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_ExprLong tcl
X.BS
X.SH NAME
XTcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBool, Tcl_ExprString \- evaluate an expression

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR

X.VS
X.sp
Xint
X\fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR)
X.sp
Xint
X\fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR)
X.sp
Xint
X\fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR)
X.sp
Xint
X\fBTcl_ExprString\fR(\fIinterp, string\fR)

X.SH ARGUMENTS
X.AS Tcl_Interp *interp
X.AP Tcl_Interp *interp in

XInterpreter in whose context to evaluate \fIstring\fR.
X.AP char *string in
XExpression to be evaluated.
X.AP long *longPtr out
XPointer to location in which to store the integer value of the
Xexpression.
X.AP int *doublePtr out
XPointer to location in which to store the floating-point value of the
Xexpression.
X.AP int *booleanPtr out
XPointer to location in which to store the 0/1 boolean value of the
Xexpression.

X.BE
X
X.SH DESCRIPTION
X.PP

XThese four procedures all evaluate a string expression, returning
Xthe result in one of four different forms.
XThe expression is given by the \fIstring\fR argument, and it
Xcan have any of the forms accepted by the \fBexpr\fR command.
XThe \fIinterp\fR argument refers to an interpreter used to
Xevaluate the expression (e.g. for variables and nested Tcl
Xcommands) and to return error information. \fIInterp->result\fR
Xis assumed to be initialized in the standard fashion when any
Xof the procedures are invoked.
X.PP
XFor all of these procedures the return value is a standard
XTcl result: \fBTCL_OK\fR means the expression was succesfully
Xevaluated, and \fBTCL_ERROR\fR means that an error occurred while
Xevaluating the expression. If \fBTCL_ERROR\fR is returned then
X\fIinterp->result\fR will hold a message describing the error.
XIf an error occurs while executing a Tcl command embedded in
X\fIstring\fR, then that error will be returned.
X.PP
XIf the expression is successfully evaluated, then its value will
Xbe returned in one of four forms, depending on which procedure
Xis invoked.
X\fBTcl_ExprLong\fR stores an integer value at \fI*longPtr\fR.
XIf the expression's actual value was a floating-point number,
Xthen it is truncated to an integer.
XIf the expression's actual value was a non-numeric string then
Xan error is returned.
X.PP
X\fBTcl_ExprDouble\fR stores a floating-point value at \fI*doublePtr\fR.
XIf the expression's actual value was an integer, it is converted to
Xfloating-point.
XIf the expression's actual value was a non-numeric string then
Xan error is returned.
X.PP
X\fBTcl_ExprBoolean\fR stores a 0/1 integer value at \fI*booleanPtr\fR.
XIf the expression's actual value was an integer or floating-point
Xnumber, then \fBTcl_ExprBoolean\fR stores 0 at \fI*booleanPtr\fR if
Xthe value was zero and 1 otherwise.
XIf the expression's actual value was a non-numeric string then
Xan error is returned.
X.PP
X\fBTcl_ExprString\fR returns the value of the expression as a
Xstring stored in \fIinterp->result\fR.
XIf the expression's actual value was an integer or floating-point
Xnumber, then \fBTcl_ExprString\fR converts it to string (using \fBsprintf\fR
Xwith a ``%d'' or ``%g'' converter).
X
X.SH KEYWORDS
Xboolean, double, evaluate, expression, integer, string
X.VE
END_OF_FILE
if test 7263 -ne `wc -c <'tcl6.1/doc/ExprLong.man'`; then
echo shar: \"'tcl6.1/doc/ExprLong.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/ExprLong.man'
fi
if test -f 'tcl6.1/doc/GetInt.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/GetInt.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/GetInt.man'\" $6873 characters$
sed "s/^X//" >'tcl6.1/doc/GetInt.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/GetInt.man,v 1.2 90/07/28 10:59:43 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_GetInt tcl
X.BS
X.SH NAME
XTcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xint
X\fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR)
X.sp
Xint
X\fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR)
X.sp
Xint
X\fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR)

X.SH ARGUMENTS
X.AS Tcl_Interp *interp
X.AP Tcl_Interp *interp in

XInterpreter to use for error reporting.
X.AP char *string in
XTextual value to be converted.
X.AP int *intPtr out
XPoints to place to store integer value converted from \fIstring\fR.
X.AP double *doublePtr out
XPoints to place to store double-precision floating-point
Xvalue converted from \fIstring\fR.
X.AP int *boolPtr out
XPoints to place to store boolean value (0 or 1) converted from \fIstring\fR.

X.BE
X
X.SH DESCRIPTION
X.PP

XThese procedures convert from strings to integers or double-precision
Xfloating-point values or booleans (represented as 0- or 1-valued
Xintegers). Each of the procedures takes a \fIstring\fR argument,
Xconverts it to an internal form of a particular type, and stores
Xthe converted value at the location indicated by the procedure's
Xthird argument. If all goes well, each of the procedures returns
XTCL_OK. If \fIstring\fR doesn't have the proper syntax for the
Xdesired type then TCL_ERROR is returned, an error message is left
Xin \fIinterp->result\fR, and nothing is stored at *\fIintPtr\fR
Xor *\fIdoublePtr\fR or *\fIboolPtr\fR.
X.PP
X\fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection
Xof integer digits, optionally signed and optionally preceded by
Xwhite space. If the first two characters of \fIstring\fR are ``0x''
Xthen \fIstring\fR is expected to be in hexadecimal form; otherwise,
Xif the first character of \fIstring\fR is ``0'' then \fIstring\fR
Xis expected to be in octal form; otherwise, \fIstring\fR is
Xexpected to be in decimal form.
X.PP
X\fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point
Xnumber, which is: white space; a sign; a sequence of digits; a
Xdecimal point; a sequence of digits; the letter ``e''; and a
Xsigned decimal exponent. Any of the fields may be omitted, except that
Xthe digits either before or after the decimal point must be present
Xand if the ``e'' is present then it must be followed by the
Xexponent number.
X.PP
X\fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean
Xvalue. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR, or
X\fBno\fR, then \fBTcl_GetBoolean\fR stores a zero value at
X\fI*boolPtr\fR. If \fIstring\fR is any of \fB1\fR, \fBtrue\fR,
Xor \fByes\fR, then 1 is stored at \fI*boolPtr\fR. Any of these
Xvalues may be abbreviated, and upper-case spellings are also
Xacceptable.
X
X.SH KEYWORDS
Xboolean, conversion, double, floating-point, integer
END_OF_FILE
if test 6873 -ne `wc -c <'tcl6.1/doc/GetInt.man'`; then
echo shar: \"'tcl6.1/doc/GetInt.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/GetInt.man'
fi
if test -f 'tcl6.1/tclUnix.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclUnix.h'\"
else
echo shar: Extracting \"'tcl6.1/tclUnix.h'\" $6487 characters$
sed "s/^X//" >'tcl6.1/tclUnix.h' <<'END_OF_FILE'
X/*
X * tclUnix.h --
X *
X * This file reads in UNIX-related header files and sets up
X * UNIX-related macros for Tcl's UNIX core. It should be the
X * only file that contains #ifdefs to handle different flavors
X * of UNIX. This file sets up the union of all UNIX-related
X * things needed by any of the Tcl core files. This file
X * depends on configuration #defines in tclConfig.h
X *
X * The material in this file was originally contributed by
X * Karl Lehenbauer, Mark Diekhans and Peter da Silva.

X *
X * Copyright 1991 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 this copyright
X * notice appears 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 * $Header: /user6/ouster/tcl/RCS/tclUnix.h,v 1.21 91/11/07 09:41:54 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _TCLUNIX
X#define _TCLUNIX
X
X/*
X * The following #defines are used to distinguish between different
X * UNIX systems. These #defines are normally set by the "config" script
X * based on information it gets by looking in the include and library
X * areas. The defaults below are for BSD-based systems like SunOS
X * or Ultrix.
X *
X * TCL_GETTOD - 1 means there exists a library procedure
X * "gettimeofday" (e.g. BSD systems). 0 means
X * have to use "times" instead.
X * TCL_GETWD - 1 means there exists a library procedure
X * "getwd" (e.g. BSD systems). 0 means
X * have to use "getcwd" instead.
X * TCL_SYS_ERRLIST - 1 means that the array sys_errlist is
X * defined as part of the C library.
X * TCL_SYS_TIME_H - 1 means there exists an include file
X * <sys/time.h> (e.g. BSD derivatives).
X * TCL_SYS_WAIT_H - 1 means there exists an include file
X * <sys/wait.h> that defines constants related
X * to the results of "wait".
X * TCL_UNION_WAIT - 1 means that the "wait" system call returns
X * a structure of type "union wait" (e.g. BSD
X * systems). 0 means "wait" returns an int
X * (e.g. System V and POSIX).
X * TCL_PID_T - 1 means that <sys/types> defines types
X * pid_t and uid_t. 0 means that it doesn't.
X */
X
X#define TCL_GETTOD 0
X#define TCL_GETWD 0
X#define TCL_SYS_ERRLIST 1
X#define TCL_SYS_TIME_H 1
X#define TCL_SYS_WAIT_H 1
X#define TCL_UNION_WAIT 0
X#define TCL_PID_T 1
X
X#include <errno.h>
X#include <fcntl.h>
X#include <limits.h>
X#include <pwd.h>
X#include <signal.h>
X#include <sys/param.h>
X#include <sys/types.h>
X#include <dirent.h>
X#include <sys/file.h>
X#include <sys/stat.h>
X#if TCL_SYS_TIME_H
X# include <sys/time.h>
X#else
X# include <time.h>
X#endif
X#if TCL_SYS_WAIT_H
X# include <sys/wait.h>
X#endif
X
X/*
X * Not all systems declare the errno variable in errno.h. so this
X * file does it explicitly. The list of system error messages also
X * isn't generally declared in a header file anywhere.
X */
X
Xextern int errno;
Xextern int sys_nerr;
Xextern char *sys_errlist[];
X
X/*
X * The type of the status returned by wait varies from UNIX system
X * to UNIX system. The macro below defines it:
X */
X
X#if TCL_UNION_WAIT
X# define WAIT_STATUS_TYPE union wait
X#else
X# define WAIT_STATUS_TYPE int
X#endif
X
X/*
X * Supply definitions for macros to query wait status, if not already
X * defined in header files above.
X */
X
X#ifndef WIFEXITED
X# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
X#endif
X
X#ifndef WEXITSTATUS
X# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
X#endif
X
X#ifndef WIFSIGNALED
X# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
X#endif
X
X#ifndef WTERMSIG
X# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f)
X#endif
X
X#ifndef WIFSTOPPED
X# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177)
X#endif
X
X#ifndef WSTOPSIG
X# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff)
X#endif
X
X/*
X * Supply macros for seek offsets, if they're not already provided by
X * an include file.
X */
X
X#ifndef SEEK_SET
X# define SEEK_SET 0
X#endif
X
X#ifndef SEEK_CUR
X# define SEEK_CUR 1
X#endif
X
X#ifndef SEEK_END
X# define SEEK_END 2
X#endif
X
X/*
X * The stuff below is needed by the "time" command. If this
X * system has no gettimeofday call, then must use times and the
X * CLK_TCK #define (from sys/param.h) to compute elapsed time.
X * Unfortunately, some systems only have HZ and no CLK_TCK, and
X * some might not even have HZ.
X */
X
X#if ! TCL_GETTOD
X# include <sys/times.h>
X# include <sys/param.h>
X# ifndef CLK_TCK
X# ifdef HZ
X# define CLK_TCK HZ
X# else
X# define CLK_TCK 60
X# endif
X# endif
X#endif
X
X/*
X * Define access mode constants if they aren't already defined.
X */
X
X#ifndef F_OK
X# define F_OK 00
X#endif
X#ifndef X_OK
X# define X_OK 01
X#endif
X#ifndef W_OK
X# define W_OK 02
X#endif
X#ifndef R_OK
X# define R_OK 04
X#endif
X
X/*
X * Make sure that MAXPATHLEN is defined.
X */
X
X#ifndef MAXPATHLEN
X# ifdef _POSIX_PATH_MAX
X# define MAXPATHLEN _POSIX_PATH_MAX
X# else
X# define MAXPATHLEN 2048
X# endif
X#endif
X
X/*
X * Define pid_t and uid_t if they're not already defined.
X */
X
X#if ! TCL_PID_T
X# define pid_t int
X# define uid_t int
X#endif
X
X/*
X * Variables provided by the C library:
X */
X
Xextern char **environ;
X
X/*
X * Library procedures used by Tcl but not declared in a header file:
X */
X
Xextern int access _ANSI_ARGS_((CONST char *path, int mode));
Xextern int chdir _ANSI_ARGS_((CONST char *path));
Xextern int close _ANSI_ARGS_((int fd));
Xextern int dup2 _ANSI_ARGS_((int src, int dst));
Xextern int execvp _ANSI_ARGS_((CONST char *name, char **argv));
Xextern void _exit _ANSI_ARGS_((int status));
Xextern pid_t fork _ANSI_ARGS_((void));
Xextern uid_t geteuid _ANSI_ARGS_((void));
Xextern pid_t getpid _ANSI_ARGS_((void));
Xextern char * getcwd _ANSI_ARGS_((char *buffer, int size));
Xextern char * getwd _ANSI_ARGS_((char *buffer));
Xextern int kill _ANSI_ARGS_((pid_t pid, int sig));
Xextern long lseek _ANSI_ARGS_((int fd, int offset, int whence));
Xextern char * mktemp _ANSI_ARGS_((char *template));
Xextern int open _ANSI_ARGS_((CONST char *path, int flags, int mode));
Xextern int pipe _ANSI_ARGS_((int *fdPtr));
Xextern int read _ANSI_ARGS_((int fd, char *buf, int numBytes));
Xextern int unlink _ANSI_ARGS_((CONST char *path));
Xextern int write _ANSI_ARGS_((int fd, char *buf, int numBytes));
X
X#endif /* _TCLUNIX */
END_OF_FILE
if test 6487 -ne `wc -c <'tcl6.1/tclUnix.h'`; then
echo shar: \"'tcl6.1/tclUnix.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUnix.h'
fi
echo shar: End of archive 5 $of 33$.
cp /dev/null ark5isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:27:36 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 74
Archive-name: tcl/part06
Environment: UNIX

# "End of archive 6 (of 33)."
# Contents: tcl6.1/doc/AddErrInfo.man tcl6.1/doc/CrtCommand.man
# tcl6.1/doc/CrtTrace.man tcl6.1/doc/Fork.man
# tcl6.1/doc/SplitList.man
# Wrapped by karl@one on Tue Nov 12 19:44:15 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/AddErrInfo.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/AddErrInfo.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/AddErrInfo.man'\" $8975 characters$
sed "s/^X//" >'tcl6.1/doc/AddErrInfo.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/AddErrInfo.man,v 1.6 91/08/20 09:47:45 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_AddErrorInfo tcl
X.BS
X.SH NAME
XTcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_UnixError, Tcl_CheckStatus \- record information about errors

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xchar *
X\fBTcl_AddErrorInfo\fR(\fIinterp, message\fR)
X.sp
X.VS
Xvoid
X\fBTcl_SetErrorCode\fR(\fIinterp, element, element, ...\fR)
X.sp
Xchar
X\fBTcl_UnixError\fR(\fIinterp\fR)
X.VE

X.SH ARGUMENTS
X.AS Tcl_Interp *interp
X.AP Tcl_Interp *interp in

XInterpreter in which to record information.
X.AP char *message in
XIdentifying string to record in \fBerrorInfo\fR variable.
X.AP char *element in
X.VS
XString to record as one element of \fBerrorCode\fR variable.
XLast \fIelement\fR argument must be NULL.
X.VE

X.BE
X
X.SH DESCRIPTION
X.PP

X.VS
XThese procedures are used to manipulate two global variables
Xthat hold information about errors.
XThe variable \fBerrorInfo\fR holds a stack trace of the
Xoperations that were in progress when an error occurred, and
Xis intended to be human-readable.
XThe variable \fBerrorCode\fR holds a list of items that
Xare intended to be machine-readable.
XThe first item in \fBerrorCode\fR identifies the class of
Xerror that occurred (e.g. UNIX means an error occurred in
Xa Unix system call) and additional elements in \fBerrorCode\fR
Xhold additional pieces of information that depend on the class.
XSee the Tcl overview manual entry for details on the various
Xformats for \fBerrorCode\fR.
X.PP
XThe \fBerrorInfo\fR variable is gradually built up as an
Xerror unwinds through the nested operations.
XEach time an error code is returned to \fBTcl_Eval\fR
Xit calls the procedure \fBTcl_AddErrorInfo\fR to add
Xadditional text to \fBerrorInfo\fR describing the
Xcommand that was being executed when the error occurred.
XBy the time the error has been passed all the way back
Xto the application, it will contain a complete trace
Xof the activity in progress when the error occurred.
X.PP
XIt is sometimes useful to add additional information to
X\fBerrorInfo\fR beyond what can be supplied automatically
Xby \fBTcl_Eval\fR.
X\fBTcl_AddErrorInfo\fR may be used for this purpose:
Xits \fImessage\fR argument contains an additional
Xstring to be appended to \fBerrorInfo\fR.
XFor example, the \fBsource\fR command calls \fBTcl_AddErrorInfo\fR
Xto record the name of the file being processed and the
Xline number on which the error occurred; for Tcl procedures, the
Xprocedure name and line number within the procedure are recorded,
Xand so on.
XThe best time to call \fBTcl_AddErrorInfo\fR is just after
X\fBTcl_Eval\fR has returned \fBTCL_ERROR\fR.
XIn calling \fBTcl_AddErrorInfo\fR, you may find it useful to
Xuse the \fBerrorLine\fR field of the interpreter (see the
X\fBTcl_Interp\fR manual entry for details).
X.PP
XThe procedure \fBTcl_SetErrorCode\fR is used to set the
X\fBerrorCode\fR variable.
XIts \fIelement\fR arguments give one or more strings to record
Xin \fBerrorCode\fR: each \fIelement\fR will become one item
Xof a properly-formed Tcl list stored in \fBerrorCode\fR.
X\fBTcl_SetErrorCode\fR is typically invoked just before returning
Xan error.
XIf an error is returned without calling \fBTcl_SetErrorCode\fR
Xthen the Tcl interpreter automatically sets \fBerrorCode\fR
Xto \fBNONE\fR.
X.PP
X\fBTcl_UnixError\fR sets the \fBerrorCode\fR variable after an error
Xin a UNIX kernel call.
XIt reads the value of the \fBerrno\fR C variable and calls
X\fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the
X\fBUNIX\fR format.
XIn addition, \fBTcl_UnixError\fR returns a human-readable
Xdiagnostic message for the error (this is the same value that
Xwill appear as the third element in \fBerrorCode\fR).
XIt may be convenient to include this string as part of the
Xerror message returned to the application in \fIinterp->result\fR.
X.PP
XIt is important to call the procedures described here rather than
Xsetting \fBerrorInfo\fR or \fBerrorCode\fR directly with
X\fBTcl_SetVar\fR.
XThe reason for this is that the Tcl interpreter keeps information
Xabout whether these procedures have been called.
XFor example, the first time \fBTcl_AppendResult\fR is called
Xfor an error, it clears the existing value of \fBerrorInfo\fR
Xand adds the error message in \fIinterp->result\fR to the variable
Xbefore appending \fImessage\fR; in subsequent calls, it just
Xappends the new \fImessage\fR.
XWhen \fBTcl_SetErrorCode\fR is called, it sets a flag indicating
Xthat \fBerrorCode\fR has been set; this allows the Tcl interpreter
Xto set \fBerrorCode\fR to \fBNONE\fB if it receives an error return
Xwhen \fBTcl_SetErrorCode\fR hasn't been called.
X.PP
XIf the procedure \fBTcl_ResetResult\fR is called, it clears all
Xof the state associated with \fBerrorInfo\fR and \fBerrorCode\fR
X(but it doesn't actually modify the variables).
XIf an error had occurred, this will clear the error state to
Xmake it appear as if no error had occurred after all.
X.VE
X
X.SH "SEE ALSO"
XTcl_ResetResult, Tcl_Interp
X
X.SH KEYWORDS
Xerror, stack, trace, variable
END_OF_FILE
if test 8975 -ne `wc -c <'tcl6.1/doc/AddErrInfo.man'`; then
echo shar: \"'tcl6.1/doc/AddErrInfo.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/AddErrInfo.man'
fi
if test -f 'tcl6.1/doc/CrtCommand.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/CrtCommand.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/CrtCommand.man'\" $8815 characters$
sed "s/^X//" >'tcl6.1/doc/CrtCommand.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/man/RCS/CrtCommand.man,v 1.5 91/11/01 14:41:04 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_CreateCommand tcl
X.BS
X.SH NAME
XTcl_CreateCommand, Tcl_DeleteCommand \- define application-specific command bindings

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

X\fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR)
X.sp
Xint
X\fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR)
X.SH ARGUMENTS
X.AS Tcl_CmdDeleteProc (*deleteProc)()
X.AP Tcl_Interp *interp in
XInterpreter in which to create new command.
X.AP char *cmdName in
XName of command to create or delete.
X.AP Tcl_CmdProc *proc in
XImplementation of new command: \fIproc\fR will be called whenever
X\fIcmdName\fR is invoked as a command.
X.AP ClientData clientData in
XArbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR.
X.AP Tcl_CmdDeleteProc *deleteProc in
XProcedure to call before \fIcmdName\fR is deleted from the interpreter;
Xallows for command-specific cleanup. If NULL, then no procedure is
Xcalled before the command is deleted.

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates
Xit with procedure \fIproc\fR such that whenever \fIcmdName\fR is
Xinvoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter
Xwill call \fIproc\fR
Xto process the command. If there is already a command \fIcmdName\fR
Xassociated with the interpreter, it is deleted. \fIProc\fP should
Xhave arguments and result that match the type \fBTcl_CmdProc\fR:
X.nf
X.RS
Xtypedef int Tcl_CmdProc(
X.RS
XClientData \fIclientData\fR,
XTcl_Interp *\fIinterp\fR,
Xint \fIargc\fR,
Xchar *\fIargv\fR[]);
X.RE
X.RE
X.fi
XWhen \fIproc\fR is invoked the \fIclientData\fP and \fIinterp\fR
Xparameters will be copies of the \fIclientData\fP and \fIinterp\fR
Xarguments given to \fBTcl_CreateCommand\fR.
XTypically, \fIclientData\fR points to an application-specific
Xdata structure that describes what to do when the command procedure
Xis invoked. \fIArgc\fR and \fIargv\fR describe the arguments to
Xthe command, \fIargc\fR giving the number of arguments (including
Xthe command name) and \fIargv\fR giving the values of the arguments
Xas strings. The \fIargv\fR array will contain \fIargc\fR+1 values;
Xthe first \fIargc\fR values point to the argument strings, and the
Xlast value is NULL.
X.PP
X\fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR,
X\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page
Xfor details on what these codes mean. Most normal commands will only
Xreturn \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set
X\fIinterp->result\fR to point to a string value;
Xin the case of a \fBTCL_OK\fR return code this gives the result
Xof the command, and in the case of \fBTCL_ERROR\fR it gives an error message.
XThe \fBTcl_SetResult\fR procedure provides an easy interface for setting
Xthe return value; for complete details on how the \fIinterp->result\fR
Xfield is managed, see the \fBTcl_Interp\fR man page.
XBefore invoking a command procedure,
X\fBTcl_Eval\fR sets \fIinterp->result\fR to point to an empty string, so simple
Xcommands can return an empty result by doing nothing at all.
X.PP
XThe contents of the \fIargv\fR array are copies made by the Tcl interpreter
Xfor the use of \fIproc\fR. \fIProc\fR may alter any of the strings
Xin \fIargv\fR. However, the \fIargv\fR array
Xis recycled as soon as \fIproc\fR returns, so \fIproc\fR must not set
X\fIinterp->result\fR to point anywhere within the \fIargv\fR values
X(call Tcl_SetResult
Xwith status \fBTCL_VOLATILE\fR if you want to return something from the
X\fIargv\fR array).
X.PP
X\fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted.
XThis can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR,
Xor by replacing \fIcmdName\fR in another call to Tcl_CreateCommand.
X\fIDeleteProc\fR is invoked before the command is deleted, and gives the
Xapplication an opportunity to release any structures associated
Xwith the command. \fIDeleteProc\fR should have arguments and
Xresult that match the type \fBTcl_CmdDeleteProc\fR:
X.nf
X.RS
X.sp
Xtypedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR);
X.sp
X.RE
X.fi
XThe \fIclientData\fR argument will be the same as the \fIclientData\fR
Xargument passed to \fBTcl_CreateCommand\fR.
X.PP
X\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
XOnce the call completes, attempts to invoke \fIcmdName\fR in
X\fIinterp\fR will result in errors.
XIf \fIcmdName\fR isn't bound as a command in \fIinterp\fR then
X\fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise
Xit returns 0.
XThere are no restrictions on \fIcmdName\fR: it may refer to
Xa built-in command, an application-specific command, or a Tcl procedure.
X
X.SH KEYWORDS
Xbind, command, create, delete, interpreter
END_OF_FILE
if test 8815 -ne `wc -c <'tcl6.1/doc/CrtCommand.man'`; then
echo shar: \"'tcl6.1/doc/CrtCommand.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/CrtCommand.man'
fi
if test -f 'tcl6.1/doc/CrtTrace.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/CrtTrace.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/CrtTrace.man'\" $8294 characters$
sed "s/^X//" >'tcl6.1/doc/CrtTrace.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/man/RCS/CrtTrace.man,v 1.4 91/11/01 14:41:15 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_CreateTrace tcl
X.BS
X.SH NAME
XTcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

XTcl_Trace
X\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR)
X.sp
X\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
X.SH ARGUMENTS
X.AS Tcl_CmdTraceProc (clientData)()
X.AP Tcl_Interp *interp in
XInterpreter containing command to be traced or untraced.
X.AP int level in
XOnly commands at or below this nesting level will be traced. 1 means
Xtop-level commands only, 2 means top-level commands or those that are
Xinvoked as immediate consequences of executing top-level commands
X(procedure bodies, bracketed commands, etc.) and so on.
X.AP Tcl_CmdTraceProc *proc in
XProcedure to call for each command that's executed. See below for
Xdetails on the calling sequence.
X.AP ClientData clientData in
XArbitrary one-word value to pass to \fIproc\fR.
X.AP Tcl_Trace trace in
XToken for trace to be removed (return value from previous call
Xto \fBTcl_CreateTrace\fR).

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_CreateTrace\fR arranges for command tracing. From now on, \fIproc\fR
Xwill be invoked before Tcl calls command procedures to process
Xcommands in \fIinterp\fR. The return value from
X\fBTcl_CreateTrace\fR is a token for the trace,
Xwhich may be passed to \fBTcl_DeleteTrace\fR to remove the trace. There may
Xbe many traces in effect simultaneously for the same command interpreter.
X.PP
X\fIProc\fR should have arguments and result that match the
Xtype \fBTcl_CmdTraceProc\fR:
X.nf
X.sp
X.RS
Xtypedef void Tcl_CmdTraceProc(
X.RS
XClientData \fIclientData\fR,
XTcl_Interp *\fIinterp\fR,
Xint \fIlevel\fR,
Xchar *\fIcommand\fR,
XTcl_CmdProc *\fIcmdProc\fR,
XClientData \fIcmdClientData\fR,
Xint \fIargc\fR,
Xchar *\fIargv\fR[]));
X.sp
X.RE
X.RE
X.fi
XThe \fIclientData\fP and \fIinterp\fP parameters are
Xcopies of the corresponding arguments given to \fBTcl_CreateTrace\fR.
X\fIClientData\fR typically points to an application-specific
Xdata structure that describes what to do when \fIproc\fR
Xis invoked. \fILevel\fR gives the nesting level of the command
X(1 for top-level commands passed to \fBTcl_Eval\fR by the application,
X2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing
Xor interpreting level-1 commands, and so on). \fICommand\fR
Xpoints to a string containing the text of the
Xcommand, before any argument substitution.
X\fICmdProc\fR contains the address of the command procedure that
Xwill be called to process the command (i.e. the \fIproc\fR argument
Xof some previous call to \fBTcl_CreateCommand\fR) and \fIcmdClientData\fR
Xcontains the associated client data for \fIcmdProc\fR (the \fIclientData\fR
Xvalue passed to \fBTcl_CreateCommand\fR). \fIArgc\fR and \fIargv\fR give
Xthe final argument information that will be passed to \fIcmdProc\fR, after
Xcommand, variable, and backslash substitution.
X\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
X.PP
XTracing will only occur for commands at nesting level less than
Xor equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR
Xparameter to \fIproc\fR will always be less than or equal to the
X\fIlevel\fR parameter to \fBTcl_CreateTrace\fR).
X.PP
XCalls to \fIproc\fR will be made by the Tcl parser immediately before
Xit calls the command procedure for the command (\fIcmdProc\fR). This
Xoccurs after argument parsing and substitution, so tracing for
Xsubstituted commands occurs before tracing of the commands
Xcontaining the substitutions. If there is a syntax error in a
Xcommand, or if there is no command procedure associated with a
Xcommand name, then no tracing will occur for that command. If a
Xstring passed to Tcl_Eval contains multiple commands (bracketed, or
Xon different lines) then multiple calls to \fIproc\fR will occur,
Xone for each command. The \fIcommand\fR string for each of these
Xtrace calls will reflect only a single command, not the entire string
Xpassed to Tcl_Eval.
X.PP
X\fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be
Xmade to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR
Xreturns, the caller should never again use the \fItrace\fR token.
X
X.SH KEYWORDS
Xcommand, create, delete, interpreter, trace
END_OF_FILE
if test 8294 -ne `wc -c <'tcl6.1/doc/CrtTrace.man'`; then
echo shar: \"'tcl6.1/doc/CrtTrace.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/CrtTrace.man'
fi
if test -f 'tcl6.1/doc/Fork.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Fork.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Fork.man'\" $9119 characters$
sed "s/^X//" >'tcl6.1/doc/Fork.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Fork.man,v 1.2 91/10/09 11:58:25 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_Fork tcl
X.BS
X.VS
X.SH NAME
XTcl_Fork, Tcl_WaitPids, Tcl_DetachPids \- manage child processes

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp
Xint

X\fBTcl_Fork\fR( )
X.sp
Xint
X\fBTcl_WaitPids\fR(\fInumPids, pidPtr, statusPtr\fR)
X.sp
Xint
X\fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR)
X.SH ARGUMENTS
X.AS Tcl_Interp *statusPtr
X.AP int numPids in
XNumber of process ids contained in the array pointed to by \fIpidPtr\fR.
X.AP int *pidPtr in
XAddress of array containing \fInumPids\fR process ids.
X.AP int *statusPtr out
XAddress of place to store status returned by exited/suspended process.

X.BE
X
X.SH DESCRIPTION
X.PP

XThese procedures keep track of child processes in order to make it
Xeasier for one application to manage several children.
XIf an application uses
Xthe UNIX \fIfork\fR and \fIwait\fR kernel calls directly,
Xproblems occur in situations like the following:
X.IP [1]
XOne part of an application creates child C1. It plans to
Xlet the child run in background, then later wait for it to
Xcomplete.
X.IP [2]
XSome other part of the application creates another child C2,
Xnot knowing anything about C1.
X.IP [3]
XThe second part of the application uses \fIwait\fR to wait for C2
Xto complete.
X.IP [4]
XC1 completes before C2, so C1 is returned by the
X\fIwait\fR kernel call.
X.IP [5]
XThe second part of the application doesn't recognize C1, so it
Xignores it and calls \fIwait\fR again. This time C2
Xcompletes.
X.IP [6]
XThe first part of the application eventually decides to wait
Xfor its child to complete. When it calls \fIwait\fR there are
Xno children left, so \fIwait\fR returns an error and the
Xapplication never gets to examine the exit status for C1.
X.PP
XThe procedures \fBTcl_Fork\fR, \fBTcl_WaitPids\fR, and \fBTcl_DetachPids\fR
Xget around this problem by keeping a table of child processes and
Xtheir exit statuses.
XThey also provide a more flexible waiting
Xmechanism than the \fIwait\fR kernel call.
XTcl-based applications should never call \fIfork\fR and
X\fIwait\fR directly; they should use \fBTcl_Fork\fR,
X\fBTcl_WaitPids\fR, and \fBTcl_DetachPids\fR.
X.PP
X\fBTcl_Fork\fR calls \fIfork\fR and returns the result of
Xthe \fIfork\fR kernel call.
XIf the \fIfork\fR call was successful then \fBTcl_Fork\fR also
Xenters the new process into its internal table of child
Xproceses.
XIf \fIfork\fR returns an error then \fBTcl_Fork\fR returns that
Xsame error.
X.PP
X\fBTcl_WaitPids\fR calls \fIwait\fR repeatedly until one of the processes
Xin the \fIpidPtr\fR array has exited or been killed or suspended by a
Xsignal.
XWhen this occurs, \fBTcl_WaitPids\fR returns the process
Xidentifier for the process and stores its wait status at
X\fI*statusPtr\fR.
XIf the process no longer exists (it exited or was killed by a signal),
Xthen \fBTcl_WaitPids\fR removes its entry from the internal
Xprocess table.
XIf \fIwait\fR returns a process that isn't
Xin the \fIpidPtr\fR array, \fBTcl_WaitPids\fR saves its wait
Xstatus in the internal process table and calls \fIwait\fR again.
XIf one of the processes in the \fIpidPtr\fR array has already
Xexited (or suspended or been killed) when \fBTcl_WaitPids\fR
Xis called, that process and its wait status are returned
Ximmediately without calling \fIwait\fR.
X.PP
X\fBTcl_WaitPids\fR provides two advantages. First, it allows
Xprocesses to exit in any order, and saves their wait statuses.
XSecond, it allows waiting on a number of processes simultaneously,
Xreturning when any of the processes is returned by \fIwait\fR.
X.PP
X\fBTcl_DetachPids\fR is used to indicate that the application
Xno longer cares about the processes given by the \fIpidPtr\fR
Xarray and will never use \fBTcl_WaitPids\fR to wait for them.
XThis occurs, for example, if one or more children are to be
Xexecuted in background and the parent doesn't care whether
Xthey complete successfully.
XWhen \fBTcl_DetachPids\fR is called, the internal process
Xtable entries for the processes are marked so that the
Xentries will be removed as soon as the processes exit or
Xare killed.
X.PP
XIf none of the pids passed to \fBTcl_WaitPids\fR exists in
Xthe internal process table, then -1 is returned and \fIerrno\fR
Xis set to ECHILD.
XIf a \fIwait\fR kernel call returns an error,
Xthen \fBTcl_WaitPids\fR returns that same error.
XIf a \fIwait\fR kernel call returns a process that isn't in
Xthe internal process table, \fBTcl_WaitPids\fR panics and
Xaborts the application.
XIf this situation occurs, it means that a process has been
Xcreated without calling \fBTcl_Fork\fR and that its exit
Xstatus is about to be lost.
X.PP
X\fBTcl_WaitPids\fR defines wait statuses to have type \fIint\fR,
Xwhich is correct for POSIX and many variants of UNIX.
XSome BSD-based UNIX systems still use type \fIunion wait\fR for
Xwait statuses; it should be safe to cast a pointer to a
X\fIunion wait\fR structure to \fI(int *)\fR before passing
Xit to \fBTcl_WaitPids\fR as in the following code:
X.nf
X.RS
X
X\fBunion wait status;
Xint pid1, pid2;
X\&...
Xpid2 = Tcl_WaitPids(1, &pid1, (int *) &status);\fR
X.RE
X.fi

X
X.SH KEYWORDS
Xbackground, child, detach, fork, process, status, wait
X.VE
END_OF_FILE

if test 9119 -ne `wc -c <'tcl6.1/doc/Fork.man'`; then
echo shar: \"'tcl6.1/doc/Fork.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Fork.man'
fi
if test -f 'tcl6.1/doc/SplitList.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/SplitList.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/SplitList.man'\" $9107 characters$
sed "s/^X//" >'tcl6.1/doc/SplitList.man' <<'END_OF_FILE'
X'\" Copyright 1989-1991 Regents of the University of California

X'\" Permission to use, copy, modify, and distribute this
X'\" documentation for any purpose and without fee is hereby
X'\" granted, provided that this notice appears in all copies.
X'\" The University of California makes no representations about

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/SplitList.man,v 1.5 91/07/10 11:08:18 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_SplitList tcl
X.BS
X.SH NAME
XTcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp
Xint

X\fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR)
X.sp
Xchar *
X\fBTcl_Merge\fR(\fIargc, argv\fR)
X.sp
X.VS
Xint
X\fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR)
X.sp
Xint
X\fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR)
X.VE
X.AS Tcl_Interp *argvPtr
X.SH ARGUMENTS
X.AP Tcl_Interp *interp out

XInterpreter to use for error reporting.

X.AP char *list in
XPointer to a string with proper list structure.
X.AP int *argcPtr out
XFilled in with number of elements in \fIlist\fR.
X.AP char ***argvPtr out
X\fI*argvPtr\fR will be filled in with the address of an array of
Xpointers to the strings that are the extracted elements of \fIlist\fR.
XThere will be \fI*argcPtr\fR valid entries in the array, followed by
Xa NULL entry.
X.AP int argc in
XNumber of elements in \fIargv\fR.
X.AP char **argv in
XArray of strings to merge together into a single list.
XEach string will become a separate element of the list.
X.AP char *src in
X.VS
XString that is to become an element of a list.
X.AP int *flagsPtr in
XPointer to word to fill in with information about \fIsrc\fR.
XThe value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR.
X.AP char *dst in
XPlace to copy converted list element. Must contain enough characters
Xto hold converted string.
X.AP int flags in
XInformation about \fIsrc\fR, which must have been returned by previous
Xcall to \fBTcl_ScanElement\fR.
X.VE

X.BE
X
X.SH DESCRIPTION
X.PP

XThese procedures may be used to disassemble and reassemble Tcl lists.
X\fBTcl_SplitList\fR breaks a list up into its constituent elements,
Xreturning an array of pointers to the elements using
X\fIargcPtr\fR and \fIargvPtr\fR.
XWhile extracting the arguments, \fBTcl_SplitList\fR obeys the usual
Xrules for backslash substitutions and braces. The area of
Xmemory pointed to by \fI*argvPtr\fR is dynamically allocated; in
Xaddition to the array of pointers, it
Xalso holds copies of all the list elements. It is the caller's
Xresponsibility to free up all of this storage by calling
X.DS
X\fBfree\fR((char *) \fI*argvPtr\fR)
X.DE
Xwhen the list elements are no longer needed.
X.PP
X\fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was
Xsuccessfully parsed.
XIf there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned
Xand \fIinterp->result\fR will point to an error message describing the
Xproblem.
XIf \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR
Xis not modified.
X.PP
X\fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it
Xtakes a collection of strings given by \fIargc\fR
Xand \fIargv\fR and generates a result string
Xthat has proper list structure.
XThis means that commands like \fBindex\fR may be used to
Xextract the original elements again.
XIn addition, if the result of \fBTcl_Merge\fR is passed to \fBTcl_Eval\fR,
Xit will be parsed into \fIargc\fR words whose values will
Xbe the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR.
X\fBTcl_Merge\fR will modify the list elements with braces and/or
Xbackslashes in order to produce proper Tcl list structure.

XThe result string is dynamically allocated
Xusing \fBmalloc()\fR; the caller must eventually release the space

Xusing \fBfree()\fR.
X.PP
XIf the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR,
Xthe elements returned by \fBTcl_SplitList\fR will be identical to
Xthose passed into \fBTcl_Merge\fR.
XHowever, the converse is not true: if \fBTcl_SplitList\fR
Xis passed a given string, and the resulting \fIargc\fR and
X\fIargv\fR are passed to \fBTcl_Merge\fR, the resulting string
Xmay not be the same as the original string passed to \fBTcl_SplitList\fR.
XThis is because \fBTcl_Merge\fR may use backslashes and braces
Xdifferently than the original string.
X.PP
X.VS
X\fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR are the
Xprocedures that do all of the real work of \fBTcl_Merge\fR.
X\fBTcl_ScanElement\fR scans its \fIsrc\fR argument
Xand determines how to use backslashes and braces
Xwhen converting it to a list element.
XIt returns an overestimate of the number of characters
Xrequired to represent \fIsrc\fR as a list element, and
Xit stores information in \fI*flagsPtr\fR that is needed
Xby \fBTcl_ConvertElement\fR.
X.PP
X\fBTcl_ConvertElement\fR is a companion procedure to \fBTcl_ScanElement\fR.
XIt does the actual work of converting a string to a list element.
XIts \fIflags\fR argument must be the same as the value returned
Xby \fBTcl_ScanElement\fR.
X\fBTcl_ConvertElement\fR writes a proper list element to memory
Xstarting at *\fIdst\fR and returns a count of the total number
Xof characters written, which will be no more than the result
Xreturned by \fBTcl_ScanElement\fR.
X\fBTcl_ConvertElement\fR writes out only the actual list element
Xwithout any leading or trailing spaces: it is up to the caller to
Xinclude spaces between adjacent list elements.
X.VE
X
X.SH KEYWORDS
Xbackslash, convert, element, list, merge, split, strings
END_OF_FILE
if test 9107 -ne `wc -c <'tcl6.1/doc/SplitList.man'`; then
echo shar: \"'tcl6.1/doc/SplitList.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/SplitList.man'
fi
echo shar: End of archive 6 $of 33$.
cp /dev/null ark6isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:28:00 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 75
Archive-name: tcl/part07
Environment: UNIX

# "End of archive 7 (of 33)."
# Contents: tcl6.1/config tcl6.1/doc/Interp.man tcl6.1/tests/file.test
# tcl6.1/tests/proc.test tcl6.1/tests/regexp.test
# Wrapped by karl@one on Tue Nov 12 19:44:16 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/config' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/config'\"
else
echo shar: Extracting \"'tcl6.1/config'\" $9141 characters$
sed "s/^X//" >'tcl6.1/config' <<'END_OF_FILE'
X#!/bin/csh -f
X#
X# This script should be executed to configure the Tcl source directory
X# for a particular system. It probes the system for various header
X# files and library object files. Where things needed by Tcl are missing,
X# substitute versions are included from the "compat" subdirectory.
X#
X# $Header: /user6/ouster/tcl/RCS/config,v 1.19 91/11/07 10:33:05 ouster Exp $ SPRITE (Berkeley)

X#--------------------------------------------------------------
X# The variable definitions below configure this script: they
X# tell where system-defined things are kept (so this program
X# can tell whether the system contains certain features needed
X# by Tcl), and they indicate which Tcl files to modify to
X# reflect the configuration.
X
X# Directory containing system include files:
X
Xset includeDir="/usr/include"
X
X# Archive file containing object code for standard C library:
X
Xset libc="/lib/Llibc.a"
X
X# Makefile to modify:
X
Xset makefile="Makefile"
X
X# Header file to modify to hold #defines about system configuration:
X
Xset config="tclUnix.h"
X#--------------------------------------------------------------
X
Xset changes=0
Xunset time
X
X# First make sure that the configuration variables have been
X# set in a reasonable fashion.
X
Xif ( ! -r $includeDir/stdio.h ) then
X echo "- ERROR\!\! $includeDir doesn't seem to contain standard system"
X echo " include files. Please edit config to set the includeDir"
X echo " variable."
X exit(1)
Xendif
Xif ( ! -r $libc ) then
X echo "- ERROR\!\! C library $libc doesn\'t exist. Please edit config"
X echo " to set the libc variable."
X exit(1)
Xendif
Xnm -p $libc > tmp.libc
Xif ( $status != 0 ) then
X echo "- ERROR\!\! Nm failed to extract names of system-supplied library"
X echo " procedures from $libc. You'll have to modify config by hand to"
X echo " fix the problem (whatever it is)."
X exit(1)
Xendif
X
X# Since nm produces different output on different machines, the code
X# below attempts to guess what pattern to grep for in the nm output.
X
Xset pattern="[ADIT]"
Xset x=`grep printf tmp.libc | grep -c CODE`
Xif ( $x ) then
X set pattern=CODE
Xendif
X
X# Check in the C library for particular library procedures and
X# variables needed by Tcl.
X
Xset gettod=`grep gettimeofday tmp.libc | grep -c "$pattern"`
Xif ( $gettod > 1 ) set gettod=1
Xset getwd=`grep getwd tmp.libc | grep -c "$pattern"`
Xif ( $getwd > 1 ) set getwd=1
Xset opendir=`grep opendir tmp.libc | grep -c "$pattern"`
Xif ( $opendir > 1 ) set opendir=1
Xset strerror=`grep strerror tmp.libc | grep -c "$pattern"`
Xif ( $strerror > 1 ) set strerror=1
Xset strstr=`grep strstr tmp.libc | grep -c "$pattern"`
Xif ( $strstr > 1 ) set strstr=1
Xset strtol=`grep strtol tmp.libc | grep -c "$pattern"`
Xif ( $strtol > 1 ) set strtol=1
Xset strtoul=`grep strtoul tmp.libc | grep -c "$pattern"`
Xif ( $strtoul > 1 ) set strtoul=1
Xset sys_errlist=`grep sys_errlist tmp.libc | grep -c "$pattern"`
Xif ( $sys_errlist > 1 ) set sys_errlist=1
X\rm tmp.libc
X
X# Check in <sys/types.h> for definitions for pid_t and uid_t,
X# which are needed by Tcl.
X
Xset pid_t=0
Xset chk1=`grep -c pid_t $includeDir/sys/types.h`
Xset chk2=`grep -c uid_t $includeDir/sys/types.h`
Xif ( ( $chk1 > 0 ) && ( $chk2 > 0 ) ) then
X set pid_t=1
Xendif
X
X# Next, install header files that aren't present in /usr/include.
X
Xset extraHdrs=""
Xforeach i (dirent.h limits.h)
X \rm -f $i
X if ( ! -r $includeDir/$i ) then
X cp compat/$i .
X set extraHdrs="$extraHdrs $i"
X endif
Xend
Xset stdlibOK=0
X\rm -f stdlib.h
Xif ( -r $includeDir/stdlib.h ) then
X # The check below is needed because SunOS has a stdlib that
X # doesn't declare strtod and other procedures, so we have to
X # use ours instead.
X
X set chk1=`grep -c strtol $includeDir/stdlib.h`
X set chk2=`grep -c strtoul $includeDir/stdlib.h`
X set chk3=`grep -c strtod $includeDir/stdlib.h`
X if ( $chk1 > 0 && $chk2 > 0 && $chk3 > 0 ) then
X set stdlibOK=1
X endif
Xendif
Xif ( ! $stdlibOK ) then
X cp compat/stdlib.h .
X set extraHdrs="$extraHdrs stdlib.h"
Xendif
X
X# Even if string.h exists it's not complete on all systems. If
X# some of the procedures we need are missing from the library, then
X# also install a Tcl-specific string.h.
X
X\rm -f string.h
Xif ( ! $strstr || ! $strtoul || ! -r $includeDir/string.h ) then
X cp compat/string.h .
X set extraHdrs="$extraHdrs string.h"
Xendif
Xif ( "$extraHdrs" != "" ) then
X echo "- Substitutes will be used for the following header files,"
X echo " which aren't in ${includeDir} or aren't complete:"
X echo " $extraHdrs"
X set changes=1
Xendif
X
X# Next, install C procedures for missing library functions.
X
Xset extraLibs=""
X\rm -f strerror.c
Xif ( ! $strerror ) then
X set extraLibs="$extraLibs strerror"
X cp compat/strerror.c .
Xendif
X\rm -f opendir.c
Xif ( ! $opendir ) then
X set extraLibs="$extraLibs opendir"
X cp compat/opendir.c .
X \rm -f dirent.h
X cp compat/dirent2.h dirent.h
X echo "- No opendir/readdir/closedir library exists in this system,"
X echo " so substitutes will be provided. This system better have"
X echo " V7-style directories\!"
Xendif
X\rm -f strstr.c
Xif ( ! $strstr ) then
X set extraLibs="$extraLibs strstr"
X cp compat/strstr.c .
Xendif
X\rm -f strtol.c
Xif ( ! $strtol ) then
X set extraLibs="$extraLibs strtol"
X cp compat/strtol.c .
Xendif
X\rm -f strtoul.c
Xif ( ! $strtoul ) then
X set extraLibs="$extraLibs strtoul"
X cp compat/strtoul.c .
Xendif
Xif ( "$extraLibs" != "" ) then
X echo "- Substitutes will be used for the following library procedures,"
X echo " which aren't in ${libc}:"
X echo " $extraLibs"
X set changes=1
Xendif
X
X# The following statements determine whether ranlib should be used
X# in the Makefile. On System-V systems it shouldn't. The only way
X# to figure this out is to run ranlib and see if it complains (ranlib
X# actually exists on some Sys-V systems, but it returns an error if
X# you run it).
X
Xset ranlibOK=0
Xcat > ranlibtest.c << EOF
X#include <stdio.h>
Xmain (argc, argv)
X int argc;
X char **argv;
X{
X printf ("Hello, world.\n");
X}
XEOF
Xcc -c ranlibtest.c
Xar cru ranlibtest.a ranlibtest.o
Xranlib ranlibtest.a >& /dev/null
Xif ( $status == 0 ) then
X set ranlibOK=1
Xelse
X echo "- This system appears to be a System V one where ranlib isn't"
X echo " used. The ranlib commands will be removed from Makefile."
X set changes=1
Xendif
X\rm -f ranlibtest.*
X
X# Modify the Makefile to include supplemental library sources, if needed.
X
Xset compatObjs=""
Xforeach i ($extraLibs)
X set compatObjs="$compatObjs $i.o"
Xend
Xif ( ! -e $makefile.bak ) mv $makefile $makefile.bak
Xif ( $ranlibOK ) then
X sed -e "s/COMPAT_OBJS =/COMPAT_OBJS =$compatObjs/" $makefile.bak > $makefile
Xelse
X sed -e "s/COMPAT_OBJS =/COMPAT_OBJS =$compatObjs/" \
X -e "/ranlib/d" $makefile.bak > $makefile
Xendif
X
X# Set the #defines in tclConfig.h to provide various pieces of system
X# configuration information at compile time (existence of header files,
X# variables, type definitions, etc.)
X
Xif ( ! $gettod ) then
X echo "- There's no gettimeofday in ${libc} so Tcl will use"
X echo ' times for the "time" command.'
X set changes=1
Xendif
Xif ( ! $getwd ) then
X echo "- There's no getwd in ${libc} so Tcl will use"
X echo ' getcwd for the "pwd" command.'
X set changes=1
Xendif
Xset errlist=1
Xif ( ! $sys_errlist && ! $strerror ) then
X echo "- Neither strerror nor sys_errlist is defined in ${libc} so"
X echo " Tcl will make a guess about errno-related messages."
X set errlist=0
X set changes=1
Xendif
Xset sysTime=0
Xif ( -r $includeDir/sys/time.h ) then
X set sysTime=1
Xendif
Xset sysWait=0
Xset unionWait=0
Xif ( -r $includeDir/sys/wait.h ) then
X set sysWait=1
X cp compat/testwait.c test.c
X make test >& /dev/null
X if ( $status == 0 ) then
X set unionWait=1
X endif
X \rm -f a.out test.c
Xendif
Xset pid_t=1
Xcp compat/testpid.c test.c
Xmake test >& /dev/null
Xset chk1=$status
Xif ( $chk1 != 0 ) then
X set pid_t=0
X echo "- The types pid_t and uid_t aren't defined in <sys/types.h>"
X echo ' so Tcl will use "int" instead.'
Xendif
X\rm -f a.out test.c
Xif ( ! -e $config.bak ) mv $config $config.bak
Xset x=\.\*\$
Xsed -e "s/define TCL_GETTOD 1/define TCL_GETTOD $gettod/" \
X -e "s/define TCL_GETWD 1/define TCL_GETWD $getwd/" \
X -e "s/define TCL_SYS_ERRLIST 1/define TCL_SYS_ERRLIST $errlist/" \
X -e "s/define TCL_SYS_TIME_H 1/define TCL_SYS_TIME_H $sysTime/" \
X -e "s/define TCL_SYS_WAIT_H 1/define TCL_SYS_WAIT_H $sysWait/" \
X -e "s/define TCL_UNION_WAIT 1/define TCL_UNION_WAIT $unionWait/" \
X -e "s/define TCL_PID_T 1/define TCL_PID_T $pid_t/" \
X$config.bak > $config
X
Xif ( ! $changes ) then
X echo "- No special modifications were needed for this system."
Xendif
END_OF_FILE
if test 9141 -ne `wc -c <'tcl6.1/config'`; then
echo shar: \"'tcl6.1/config'\" unpacked with wrong size!
fi
chmod +x 'tcl6.1/config'
# end of 'tcl6.1/config'
fi
if test -f 'tcl6.1/doc/Interp.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Interp.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Interp.man'\" $9204 characters$
sed "s/^X//" >'tcl6.1/doc/Interp.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Interp.man,v 1.6 91/09/04 16:37:59 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_Interp tcl
X.BS
X.SH NAME
XTcl_Interp \- client-visible fields of interpreter structures

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xtypedef struct {
X char *\fIresult\fR;
X.VS
X Tcl_FreeProc *\fIfreeProc\fR;
X.VE
X int \fIerrorLine\fR;
X} Tcl_Interp;
X
X.VS
Xtypedef void Tcl_FreeProc(char *\fIblockPtr\fR);

X.VE
X.BE
X
X.SH DESCRIPTION
X.PP

XThe \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp
Xstructure. This pointer is then passed into other Tcl procedures
Xto process commands in the interpreter and perform other operations
Xon the interpreter. Interpreter structures contain many many fields
Xthat are used by Tcl, but only three that may be accessed by
X.VS
Xclients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR.
X.PP
XThe \fIresult\fR and \fIfreeProc\fR fields are used to return
Xresults or error messages from commands.
XThis information is returned by command procedures back to \fBTcl_Eval\fR,
Xand by \fBTcl_Eval\fR back to its callers.
XThe \fIresult\fR field points to the string that represents the
Xresult or error message, and the \fIfreeProc\fR field tells how
Xto dispose of the storage for the string when it isn't needed anymore.
XThe easiest way for command procedures to manipulate these
Xfields is to call procedures like \fBTcl_SetResult\fR
Xor \fBTcl_AppendResult\fR; they
Xwill hide all the details of managing the fields.
XThe description below is for those procedures that manipulate the
Xfields directly.
X.PP
XWhenever a command procedure returns, it must ensure
Xthat the \fIresult\fR field of its interpreter points to the string
Xbeing returned by the command.
XThe \fIresult\fR field must always point to a valid string.
XIf a command wishes to return no result then \fIinterp->result\fR
Xshould point to an empty string.
XNormally, results are assumed to be statically allocated,
Xwhich means that the contents will not change before the next time
X\fBTcl_Eval\fR is called or some other command procedure is invoked.
XIn this case, the \fIfreeProc\fR field must be zero.
XAlternatively, a command procedure may dynamically
Xallocate its return value (e.g. using \fBmalloc\fR)
Xand store a pointer to it in \fIinterp->result\fR.
XIn this case, the command procedure must also set \fIinterp->freeProc\fR
Xto the address of a procedure that can free the value (usually \fBfree\fR).
XIf \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR
Xto free the space pointed to by \fIinterp->result\fR before it
Xinvokes the next command.
XIf a client procedure overwrites \fIinterp->result\fR when
X\fIinterp->freeProc\fR is non-zero, then it is responsible for calling
X\fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR
Xmacro should be used for this purpose).
X.PP
X\fIFreeProc\fR should have arguments and result that match the
X\fBTcl_FreeProc\fR declaration above: it receives a single
Xargument which is a pointer to the result value to free.
XIn most applications \fBfree\fR is the only non-zero value ever
Xused for \fIfreeProc\fR.
XHowever, an application may store a different procedure address
Xin \fIfreeProc\fR in order to use an alternate memory allocator
Xor in order to do other cleanup when the result memory is freed.
X.PP
XAs part of processing each command, \fBTcl_Eval\fR initializes
X\fIinterp->result\fR
Xand \fIinterp->freeProc\fR just before calling the command procedure for
Xthe command. The \fIfreeProc\fR field will be initialized to zero,
Xand \fIinterp->result\fR will point to an empty string. Commands that
Xdo not return any value can simply leave the fields alone.
X.VE
XFurthermore, the empty string pointed to by \fIresult\fR is actually
Xpart of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200).
XIf a command wishes to return a short string, it can simply copy
Xit to the area pointed to by \fIinterp->result\fR. Or, it can use
Xthe sprintf procedure to generate a short result string at the location
Xpointed to by \fIinterp->result\fR.
X.PP
XIt is a general convention in Tcl-based applications that the result
Xof an interpreter is normally in the initialized state described
Xin the previous paragraph.
XProcedures that manipulate an interpreter's result (e.g. by
Xreturning an error) will generally assume that the result
Xhas been initialized when the procedure is called.
XIf such a procedure is to be called after the result has been
Xchanged, then \fBTcl_ResetResult\fR should be called first to
Xreset the result to its initialized state.
X.PP
XThe \fIerrorLine\fR
Xfield is valid only after \fBTcl_Eval\fR returns
Xa \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR
Xfield identifies the line number of the command being executed when
Xthe error occurred. The line numbers are relative to the command
Xbeing executed: 1 means the first line of the command passed to
X\fBTcl_Eval\fR, 2 means the second line, and so on.
XThe \fIerrorLine\fR field is typically used in conjunction with
X\fBTcl_AddErrorInfo\fR to report information about where an error
Xoccurred.
X\fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR.
X
X.SH KEYWORDS
Xfree, initialized, interpreter, malloc, result
END_OF_FILE
if test 9204 -ne `wc -c <'tcl6.1/doc/Interp.man'`; then
echo shar: \"'tcl6.1/doc/Interp.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Interp.man'
fi
if test -f 'tcl6.1/tests/file.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/file.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/file.test'\" $9253 characters$
sed "s/^X//" >'tcl6.1/tests/file.test' <<'END_OF_FILE'
X# Commands covered: file

X# $Header: /user6/ouster/tcl/tests/RCS/file.test,v 1.13 91/10/17 16:22:34 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# rootname and ext
X
Xtest file-1.1 {rootname and extension options} {file ext abc.def} .def
Xtest file-1.2 {rootname and extension options} {file ro abc.def} abc
Xtest file-1.3 {rootname and extension options} {file extension a/b/c.d} .d
Xtest file-1.4 {rootname and extension options} {file rootname a/b/c.d} a/b/c
Xtest file-1.5 {rootname and extension options} {file extension a/b.c/d} {}
Xtest file-1.6 {rootname and extension options} {file rootname a/b.c/d} a/b.c/d
Xset num 7
Xforeach outer { {} a .a a. a.a } {
X foreach inner { {} a .a a. a.a } {
X set thing [format %s/%s $outer $inner]
X test file-1.$num {rootname and extension options} {
X format %s%s [file rootname $thing] [file ext $thing]
X } $thing

X set num [expr $num+1]
X }

X}
X
X# dirname and tail
X
Xtest file-2.1 {dirname and tail options} {file dirname .def} .
Xtest file-2.2 {dirname and tail options} {file tail abc.def} abc.def
Xtest file-2.3 {dirname and tail options} {file d a/b/c.d} a/b
Xtest file-2.4 {dirname and tail options} {file t a/b/c.d} c.d
Xtest file-2.5 {dirname and tail options} {file dirname a/b.c/d} a/b.c
Xtest file-2.6 {dirname and tail options} {file tail a/b.c/d} d
Xset num 7
Xforeach outer { a .a a. a.a } {
X foreach inner { {} a .a a. a.a } {
X set thing [format %s/%s $outer $inner]
X test file-2.$num {dirname and tail options} {
X format %s/%s [file dirname $thing] [file tail $thing]
X } $thing

X set num [expr $num+1]
X }

X}
X
X# exists
X
Xcatch {exec chmod 777 dir.file}
Xcatch {exec rm -f dir.file/gorp.file}

Xcatch {exec rm -f gorp.file}

Xcatch {exec rmdir dir.file}
Xtest file-3.1 {exists option} {file exists gorp.file} 0
Xtest file-3.2 {exists option} {file exists dir.file/gorp.file} 0
Xexec cat > gorp.file << abcde
Xexec mkdir dir.file
Xexec cat > dir.file/gorp.file << 12345
Xtest file-3.3 {exists option} {file exists gorp.file} 1
Xtest file-3.4 {exists option} {file exi dir.file/gorp.file} 1
X
X# The test below has to be done in /tmp rather than the current
X# directory in order to guarantee (?) a local file system: some
X# NFS file systems won't do the stuff below correctly.
X
Xcatch {exec rm /tmp/tcl.foo.dir/file}
Xcatch {exec rmdir /tmp/tcl.foo.dir}
Xexec mkdir /tmp/tcl.foo.dir
Xexec cat > /tmp/tcl.foo.dir/file << 12345
Xexec chmod 000 /tmp/tcl.foo.dir
Xif {$user != "root"} {
X test file-3.5 {exists option} {file exists /tmp/tcl.foo.dir/file} 0
X}
Xexec chmod 775 /tmp/tcl.foo.dir
Xexec rm /tmp/tcl.foo.dir/file
Xexec rmdir /tmp/tcl.foo.dir
X
X# executable
X
Xexec chmod 000 dir.file
Xif {$user != "root"} {
X test file-4.1 {executable option} {file executable gorp.file} 0
X}
Xexec chmod 775 gorp.file
Xtest file-4.2 {executable option} {file exe gorp.file} 1
X
X# isdirectory
X
Xtest file-5.1 {isdirectory option} {file isdirectory gorp.file} 0
Xtest file-5.2 {isdirectory option} {file isd dir.file} 1
X
X# isfile
X
Xtest file-6.1 {isfile option} {file isfile gorp.file} 1
Xtest file-6.2 {isfile option} {file isfile dir.file} 0
X
X# isowned
X
Xtest file-7.1 {owned option} {file owned gorp.file} 1
Xif {$user != "root"} {
X test file-7.2 {owned option} {file owned /} 0
X}
X
X# readable
X
Xexec chmod 444 gorp.file
Xtest file-8.1 {readable option} {file readable gorp.file} 1
Xexec chmod 333 gorp.file
Xif {$user != "root"} {
X test file-8.2 {readable option} {file re gorp.file} 0
X}
X
X# writable
X
Xexec chmod 555 gorp.file
Xif {$user != "root"} {
X test file-9.1 {writable option} {file writable gorp.file} 0
X}
Xexec chmod 222 gorp.file
Xtest file-9.2 {writable option} {file w gorp.file} 1
X
Xexec chmod 777 dir.file
Xexec rm dir.file/gorp.file gorp.file
Xexec rmdir dir.file
X
X# stat
X
Xexec cat > gorp.file << "Test string"
Xexec chmod 765 gorp.file
Xtest file-10.1 {stat option} {
X catch {unset stat}
X file stat gorp.file stat
X lsort [array names stat]
X} {atime ctime dev gid ino mode mtime nlink size uid}
Xtest file-10.2 {stat option} {
X catch {unset stat}
X file stat gorp.file stat
X list $stat(nlink) $stat(size) [expr $stat(mode)&0777]
X} {1 11 501}
Xtest file-10.3 {stat option} {
X string tolower [list [catch {file stat _non_existent_ stat} msg] \
X $msg $errorCode]
X} {1 {couldn't stat "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
Xtest file-10.4 {stat option} {
X list [catch {file stat _non_existent_} msg] $msg $errorCode
X} {1 {wrong # args: should be "file stat name varName"} NONE}
Xtest file-10.5 {stat option} {
X list [catch {file stat _non_existent_ a b} msg] $msg $errorCode
X} {1 {wrong # args: should be "file stat name varName"} NONE}
Xtest file-10.6 {stat option} {
X catch {unset x}
X set x 44
X list [catch {file stat gorp.file x} msg] $msg $errorCode
X} {1 {couldn't store stat information in variable "x"} NONE}
Xcatch {unset stat}
X
X# mtime, and size (I've given up trying to find a test for "atime": there
X# seem to be too many quirks in the way file systems handle this to come
X# up with a reproducible test.
X
Xtest file-11.1 {mtime and atime and size options} {
X catch {unset stat}
X file stat gorp.file stat
X list [expr {[file mtime gorp.file] == $stat(mtime)}] \
X [expr {[file atime gorp.file] == $stat(atime)}] \
X [file size gorp.file]
X} {1 1 11}
Xtest file-11.2 {mtime option} {
X set old [file mtime gorp.file]
X exec sleep 2
X set f [open gorp.file w]
X puts $f "More text"
X close $f
X set new [file mtime gorp.file]
X expr {($new > $old) && ($new <= ($old+5))}
X} {1}
Xtest file-11.3 {size option} {
X set oldsize [file size gorp.file]
X set f [open gorp.file a]
X puts $f "More text"
X close $f
X expr {[file size gorp.file] - $oldsize}
X} {10}
Xtest file-11.4 {errors in atime option} {
X list [catch {file atime _non_existent_ x} msg] $msg $errorCode
X} {1 {wrong # args: should be "file atime name"} NONE}
Xtest file-11.5 {errors in atime option} {
X string tolower [list [catch {file atime _non_existent_} msg] \
X $msg $errorCode]
X} {1 {couldn't stat "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
Xtest file-11.6 {errors in mtime option} {
X list [catch {file mtime _non_existent_ x} msg] $msg $errorCode
X} {1 {wrong # args: should be "file mtime name"} NONE}
Xtest file-11.7 {errors in mtime option} {
X string tolower [list [catch {file mtime _non_existent_} msg] $msg \
X $errorCode]
X} {1 {couldn't stat "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
Xtest file-11.8 {errors in size option} {
X list [catch {file size _non_existent_ x} msg] $msg $errorCode
X} {1 {wrong # args: should be "file size name"} NONE}
Xtest file-11.9 {errors in size option} {
X string tolower [list [catch {file size _non_existent_} msg] $msg \
X $errorCode]
X} {1 {couldn't stat "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
X
Xexec rm -f gorp.file
X
X# Error conditions
X
Xtest file-12.1 {error conditions} {
X list [catch file msg] $msg
X} {1 {wrong # args: should be "file option name ?arg ...?"}}
Xtest file-12.2 {error conditions} {
X list [catch {file x} msg] $msg
X} {1 {wrong # args: should be "file option name ?arg ...?"}}
Xtest file-12.3 {error conditions} {
X list [catch {file exists x too} msg] $msg
X} {1 {wrong # args: should be "file exists name"}}
Xtest file-12.4 {error conditions} {
X list [catch {file gorp x} msg] $msg
X} {1 {bad option "gorp": should be atime, dirname, executable, exists, \
Xextension, isdirectory, isfile, mtime, owned, readable, root, size, stat, \
Xtail, or writable}}
Xtest file-12.5 {error conditions} {
X list [catch {file ex x} msg] $msg
X} {1 {bad option "ex": should be atime, dirname, executable, exists, \
Xextension, isdirectory, isfile, mtime, owned, readable, root, size, stat, \
Xtail, or writable}}
Xtest file-12.6 {error conditions} {
X list [catch {file is x} msg] $msg
X} {1 {bad option "is": should be atime, dirname, executable, exists, \
Xextension, isdirectory, isfile, mtime, owned, readable, root, size, stat, \
Xtail, or writable}}
Xtest file-12.7 {error conditions} {
X list [catch {file r x} msg] $msg
X} {1 {bad option "r": should be atime, dirname, executable, exists, \
Xextension, isdirectory, isfile, mtime, owned, readable, root, size, stat, \
Xtail, or writable}}
Xtest file-12.8 {error conditions} {
X list [catch {file s x} msg] $msg
X} {1 {bad option "s": should be atime, dirname, executable, exists, \
Xextension, isdirectory, isfile, mtime, owned, readable, root, size, stat, \
Xtail, or writable}}
END_OF_FILE
if test 9253 -ne `wc -c <'tcl6.1/tests/file.test'`; then
echo shar: \"'tcl6.1/tests/file.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/file.test'
fi
if test -f 'tcl6.1/tests/proc.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/proc.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/proc.test'\" $9157 characters$
sed "s/^X//" >'tcl6.1/tests/proc.test' <<'END_OF_FILE'
X# Commands covered: proc, return, global

X# $Header: /user6/ouster/tcl/tests/RCS/proc.test,v 1.9 91/10/31 16:40:55 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc tproc {} {return a; return b}
Xtest proc-1.1 {simple procedure call and return} {tproc} a
Xproc tproc x {
X set x [expr $x+1]
X return $x
X}
Xtest proc-1.2 {simple procedure call and return} {tproc 2} 3
Xtest proc-1.3 {simple procedure call and return} {
X proc tproc {} {return foo}
X} {}
Xtest proc-1.4 {simple procedure call and return} {
X proc tproc {} {return}
X tproc
X} {}
X
Xtest proc-2.1 {local and global variables} {
X proc tproc x {
X set x [expr $x+1]
X return $x
X }
X set x 42
X list [tproc 6] $x
X} {7 42}
Xtest proc-2.2 {local and global variables} {
X proc tproc x {
X set y [expr $x+1]
X return $y
X }
X set y 18
X list [tproc 6] $y
X} {7 18}
Xtest proc-2.3 {local and global variables} {
X proc tproc x {
X global y
X set y [expr $x+1]
X return $y
X }
X set y 189
X list [tproc 6] $y
X} {7 7}
Xtest proc-2.4 {local and global variables} {
X proc tproc x {
X global y
X return [expr $x+$y]
X }
X set y 189
X list [tproc 6] $y
X} {195 189}
Xcatch {unset _undefined_}
Xtest proc-2.5 {local and global variables} {
X proc tproc x {
X global _undefined_
X return $_undefined_
X }
X list [catch {tproc xxx} msg] $msg
X} {1 {can't read "_undefined_": no such variable}}
Xtest proc-2.6 {local and global variables} {
X set a 114
X set b 115
X global a b
X list $a $b
X} {114 115}
X
Xproc do {cmd} {eval $cmd}
Xtest proc-3.1 {local and global arrays} {

X catch {unset a}
X set a(0) 22

X list [catch {do {global a; set a(0)}} msg] $msg
X} {0 22}
Xtest proc-3.2 {local and global arrays} {
X catch {unset a}
X set a(x) 22
X list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
X} {0 newValue newValue}
Xtest proc-3.3 {local and global arrays} {
X catch {unset a}
X set a(x) 22
X set a(y) 33
X list [catch {do {global a; unset a(y)}; array names a} msg] $msg
X} {0 x}
Xtest proc-3.4 {local and global arrays} {
X catch {unset a}
X set a(x) 22
X set a(y) 33
X list [catch {do {global a; unset a; info exists a}} msg] $msg \
X [info exists a]
X} {0 0 0}
Xtest proc-3.5 {local and global arrays} {
X catch {unset a}
X set a(x) 22
X set a(y) 33
X list [catch {do {global a; unset a(y); array names a}} msg] $msg
X} {0 x}
Xcatch {unset a}
Xtest proc-3.6 {local and global arrays} {
X catch {unset a}
X set a(x) 22
X set a(y) 33
X do {global a; do {global a; unset a}; set a(z) 22}
X list [catch {array names a} msg] $msg
X} {0 z}
Xtest proc-3.7 {local and global arrays} {
X proc t1 {args} {global info; set info 1}
X catch {unset a}
X set info {}
X do {global a; trace var a(1) w t1}
X set a(1) 44
X set info
X} 1
Xtest proc-3.8 {local and global arrays} {
X proc t1 {args} {global info; set info 1}
X catch {unset a}
X trace var a(1) w t1
X set info {}
X do {global a; trace vdelete a(1) w t1}
X set a(1) 44
X set info
X} {}
Xtest proc-3.9 {local and global arrays} {
X proc t1 {args} {global info; set info 1}
X catch {unset a}
X trace var a(1) w t1
X do {global a; trace vinfo a(1)}
X} {{w t1}}
Xcatch {unset a}
X
Xtest proc-3.1 {arguments and defaults} {
X proc tproc {x y z} {
X return [list $x $y $z]
X }
X tproc 11 12 13
X} {11 12 13}
Xtest proc-3.2 {arguments and defaults} {
X proc tproc {x y z} {
X return [list $x $y $z]
X }
X list [catch {tproc 11 12} msg] $msg
X} {1 {no value given for parameter "z" to "tproc"}}
Xtest proc-3.3 {arguments and defaults} {
X proc tproc {x y z} {
X return [list $x $y $z]
X }
X list [catch {tproc 11 12 13 14} msg] $msg
X} {1 {called "tproc" with too many arguments}}
Xtest proc-3.4 {arguments and defaults} {
X proc tproc {x {y y-default} {z z-default}} {
X return [list $x $y $z]
X }
X tproc 11 12 13
X} {11 12 13}
Xtest proc-3.5 {arguments and defaults} {
X proc tproc {x {y y-default} {z z-default}} {
X return [list $x $y $z]
X }
X tproc 11 12
X} {11 12 z-default}
Xtest proc-3.6 {arguments and defaults} {
X proc tproc {x {y y-default} {z z-default}} {
X return [list $x $y $z]
X }
X tproc 11
X} {11 y-default z-default}
Xtest proc-3.7 {arguments and defaults} {
X proc tproc {x {y y-default} {z z-default}} {
X return [list $x $y $z]
X }
X list [catch {tproc} msg] $msg
X} {1 {no value given for parameter "x" to "tproc"}}
Xtest proc-3.8 {arguments and defaults} {
X list [catch {
X proc tproc {x {y y-default} z} {
X return [list $x $y $z]
X }
X tproc 2 3
X } msg] $msg
X} {1 {no value given for parameter "z" to "tproc"}}
Xtest proc-3.9 {arguments and defaults} {
X proc tproc {x {y y-default} args} {
X return [list $x $y $args]
X }
X tproc 2 3 4 5
X} {2 3 {4 5}}
Xtest proc-3.10 {arguments and defaults} {
X proc tproc {x {y y-default} args} {
X return [list $x $y $args]
X }
X tproc 2 3
X} {2 3 {}}
Xtest proc-3.11 {arguments and defaults} {
X proc tproc {x {y y-default} args} {
X return [list $x $y $args]
X }
X tproc 2
X} {2 y-default {}}
Xtest proc-3.12 {arguments and defaults} {
X proc tproc {x {y y-default} args} {
X return [list $x $y $args]
X }
X list [catch {tproc} msg] $msg
X} {1 {no value given for parameter "x" to "tproc"}}
X
Xtest proc-4.1 {variable numbers of arguments} {
X proc tproc args {return $args}
X tproc
X} {}
Xtest proc-4.2 {variable numbers of arguments} {
X proc tproc args {return $args}
X tproc 1 2 3 4 5 6 7 8
X} {1 2 3 4 5 6 7 8}
Xtest proc-4.3 {variable numbers of arguments} {
X proc tproc args {return $args}
X tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
X} {1 {2 3} {4 {5 6} {{{7}}}} 8}
Xtest proc-4.4 {variable numbers of arguments} {
X proc tproc {x y args} {return $args}
X tproc 1 2 3 4 5 6 7
X} {3 4 5 6 7}
Xtest proc-4.5 {variable numbers of arguments} {
X proc tproc {x y args} {return $args}
X tproc 1 2
X} {}
Xtest proc-4.6 {variable numbers of arguments} {
X proc tproc {x missing args} {return $args}
X list [catch {tproc 1} msg] $msg
X} {1 {no value given for parameter "missing" to "tproc"}}
X
Xtest proc-5.1 {error conditions} {
X list [catch {proc} msg] $msg
X} {1 {wrong # args: should be "proc name args body"}}
Xtest proc-5.2 {error conditions} {
X list [catch {proc tproc b} msg] $msg
X} {1 {wrong # args: should be "proc name args body"}}
Xtest proc-5.3 {error conditions} {
X list [catch {proc tproc b c d e} msg] $msg
X} {1 {wrong # args: should be "proc name args body"}}
Xtest proc-5.4 {error conditions} {
X list [catch {proc tproc \{xyz {return foo}} msg] $msg

X} {1 {unmatched open brace in list}}

Xtest proc-5.5 {error conditions} {
X list [catch {proc tproc {{} y} {return foo}} msg] $msg
X} {1 {procedure "tproc" has argument with no name}}
Xtest proc-5.6 {error conditions} {
X list [catch {proc tproc {{} y} {return foo}} msg] $msg
X} {1 {procedure "tproc" has argument with no name}}
Xtest proc-5.7 {error conditions} {
X list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
X} {1 {too many fields in argument specifier "x 1 2"}}
Xtest proc-5.8 {error conditions} {
X catch {return}
X} 2
Xtest proc-5.9 {error conditions} {
X list [catch {return 1 2} msg] $msg
X} {1 {wrong # args: should be "return ?value?"}}
Xtest proc-5.10 {error conditions} {
X list [catch {global} msg] $msg
X} {1 {wrong # args: should be "global varName ?varName ...?"}}
Xproc tproc {} {
X set a 22
X global a
X}
Xtest proc-5.11 {error conditions} {
X list [catch {tproc} msg] $msg

X} {1 {variable "a" already exists}}

Xtest proc-5.12 {error conditions} {
X catch {rename tproc {}}
X catch {
X proc tproc {x {} z} {return foo}
X }
X list [catch {tproc 1} msg] $msg
X} {1 {invalid command name: "tproc"}}
Xtest proc-5.13 {error conditions} {
X proc tproc {} {
X set a 22
X error "error in procedure"
X return
X }
X list [catch tproc msg] $msg
X} {1 {error in procedure}}
Xtest proc-5.14 {error conditions} {
X proc tproc {} {
X set a 22
X error "error in procedure"
X return
X }
X catch tproc msg
X set errorInfo
X} {error in procedure
X while executing
X"error "error in procedure""
X (procedure "tproc" line 3)
X invoked from within
X"tproc"}
Xtest proc-5.15 {error conditions} {
X proc tproc {} {
X set a 22
X break
X return
X }
X catch tproc msg
X set errorInfo
X} {invoked "break" outside of a loop
X while executing
X"tproc"}
Xtest proc-5.16 {error conditions} {
X proc tproc {} {
X set a 22
X continue
X return
X }
X catch tproc msg
X set errorInfo
X} {invoked "continue" outside of a loop
X while executing
X"tproc"}
END_OF_FILE
if test 9157 -ne `wc -c <'tcl6.1/tests/proc.test'`; then
echo shar: \"'tcl6.1/tests/proc.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/proc.test'
fi
if test -f 'tcl6.1/tests/regexp.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/regexp.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/regexp.test'\" $9482 characters$
sed "s/^X//" >'tcl6.1/tests/regexp.test' <<'END_OF_FILE'
X# Commands covered: regexp, regsub

X# $Header: /user6/ouster/tcl/tests/RCS/regexp.test,v 1.5 91/10/27 15:20:14 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {unset foo}
Xtest regexp-1.1 {basic regexp operation} {
X regexp ab*c abbbc
X} 1
Xtest regexp-1.2 {basic regexp operation} {
X regexp ab*c ac
X} 1
Xtest regexp-1.3 {basic regexp operation} {
X regexp ab*c ab
X} 0
X
Xtest regexp-2.1 {getting substrings back from regexp} {
X set foo {}
X list [regexp ab*c abbbbc foo] $foo
X} {1 abbbbc}
Xtest regexp-2.2 {getting substrings back from regexp} {
X set foo {}
X set f2 {}
X list [regexp a(b*)c abbbbc foo f2] $foo $f2
X} {1 abbbbc bbbb}
Xtest regexp-2.3 {getting substrings back from regexp} {
X set foo {}
X set f2 {}
X list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
X} {1 abbbbc bbbb}
Xtest regexp-2.4 {getting substrings back from regexp} {
X set foo {}
X set f2 {}
X set f3 {}
X list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
X} {1 abbbbc bbbb c}
Xtest regexp-2.5 {getting substrings back from regexp} {
X set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
X set f6 {}; set f7 {}; set f8 {}; set f9 {}
X list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) 12223345556789999 \
X foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
X $f6 $f7 $f8 $f9
X} {1 12223345556789999 1 222 33 4 555 6 7 8 9999}
Xtest regexp-2.6 {getting substrings back from regexp} {
X set foo 2; set f2 2; set f3 2; set f4 2
X list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
X} {1 a a {} {}}
Xtest regexp-2.7 {getting substrings back from regexp} {
X set foo 1; set f2 1; set f3 1; set f4 1
X list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
X} {1 ac a {} c}
X
Xtest regexp-3.1 {-indices option to regexp} {
X set foo {}
X list [regexp -indices ab*c abbbbc foo] $foo
X} {1 {0 5}}
Xtest regexp-3.2 {-indices option to regexp} {
X set foo {}
X set f2 {}
X list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
X} {1 {0 5} {1 4}}
Xtest regexp-3.3 {-indices option to regexp} {
X set foo {}
X set f2 {}
X list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
X} {1 {0 5} {1 4}}
Xtest regexp-3.4 {-indices option to regexp} {
X set foo {}
X set f2 {}
X set f3 {}
X list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
X} {1 {0 5} {1 4} {5 5}}
Xtest regexp-3.5 {-indices option to regexp} {
X set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
X set f6 {}; set f7 {}; set f8 {}; set f9 {}
X list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
X 12223345556789999 \
X foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
X $f6 $f7 $f8 $f9
X} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
Xtest regexp-3.6 {getting substrings back from regexp} {
X set foo 2; set f2 2; set f3 2; set f4 2
X list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
X} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
Xtest regexp-3.7 {getting substrings back from regexp} {
X set foo 1; set f2 1; set f3 1; set f4 1
X list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
X} {1 {1 2} {1 1} {-1 -1} {2 2}}
X
Xtest regexp-4.1 {-nocase option to regexp} {
X regexp -nocase foo abcFOo
X} 1
Xtest regexp-4.2 {-nocase option to regexp} {
X set f1 22
X set f2 33
X set f3 44
X list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
X} {1 aBbbxYXxxZ Bbb xYXxx}
X
Xtest regexp-5.1 {exercise cache of compiled expressions} {
X regexp .*a b
X regexp .*b c
X regexp .*c d
X regexp .*d e
X regexp .*e f
X regexp .*a bbba
X} 1
Xtest regexp-5.2 {exercise cache of compiled expressions} {
X regexp .*a b
X regexp .*b c
X regexp .*c d
X regexp .*d e
X regexp .*e f
X regexp .*b xxxb
X} 1
Xtest regexp-5.3 {exercise cache of compiled expressions} {
X regexp .*a b
X regexp .*b c
X regexp .*c d
X regexp .*d e
X regexp .*e f
X regexp .*c yyyc
X} 1
Xtest regexp-5.4 {exercise cache of compiled expressions} {
X regexp .*a b
X regexp .*b c
X regexp .*c d
X regexp .*d e
X regexp .*e f
X regexp .*d 1d
X} 1
Xtest regexp-5.5 {exercise cache of compiled expressions} {
X regexp .*a b
X regexp .*b c
X regexp .*c d
X regexp .*d e
X regexp .*e f
X regexp .*e xe
X} 1
X
Xtest regexp-6.1 {regexp errors} {
X list [catch {regexp a} msg] $msg
X} {1 {wrong # args: should be "regexp ?-nocase? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
Xtest regexp-6.2 {regexp errors} {
X list [catch {regexp -nocase a} msg] $msg
X} {1 {wrong # args: should be "regexp ?-nocase? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
Xtest regexp-6.3 {regexp errors} {
X list [catch {regexp -nocas a} msg] $msg
X} {0 0}
Xtest regexp-6.4 {regexp errors} {
X list [catch {regexp a( b} msg] $msg
X} {1 {couldn't compile regular expression pattern: unmatched ()}}
Xtest regexp-6.5 {regexp errors} {
X list [catch {regexp a( b} msg] $msg
X} {1 {couldn't compile regular expression pattern: unmatched ()}}
Xtest regexp-6.6 {regexp errors} {
X list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
X} {1 {too many substring variables}}
Xtest regexp-6.7 {regexp errors} {
X set f1 44
X list [catch {regexp abc abc f1(f2)} msg] $msg
X} {1 {couldn't set variable "f1(f2)"}}
X
Xtest regexp-7.1 {basic regsub operation} {
X list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
X} {1 xax111aaa222xaa}
Xtest regexp-7.2 {basic regsub operation} {
X list [regsub aa+ aaaxaa &111 foo] $foo
X} {1 aaa111xaa}
Xtest regexp-7.3 {basic regsub operation} {
X list [regsub aa+ xaxaaa 111& foo] $foo
X} {1 xax111aaa}
Xtest regexp-7.4 {basic regsub operation} {
X list [regsub aa+ aaa 11&2&333 foo] $foo
X} {1 11aaa2aaa333}
Xtest regexp-7.5 {basic regsub operation} {
X list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
X} {1 xaxaaa2aaa333xaa}
Xtest regexp-7.6 {basic regsub operation} {
X list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
X} {1 xax1aaa22aaaxaa}
Xtest regexp-7.7 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
X} {1 xax1aa22aaxaa}
Xtest regexp-7.8 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
X} "1 {xax1\\aa22aaxaa}"
Xtest regexp-7.9 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
X} "1 {xax1\\122aaxaa}"
Xtest regexp-7.10 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
X} "1 {xax1\\aaaaaxaa}"
Xtest regexp-7.11 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
X} {1 xax1&aaxaa}
Xtest regexp-7.12 {basic regsub operation} {
X list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
X} {1 xaxaaaaaaaaaaaaaaxaa}
Xtest regexp-7.13 {basic regsub operation} {
X set foo xxx
X list [regsub abc xyz 111 foo] $foo
X} {0 xxx}
X
Xtest regexp-8.1 {case conversion in regsub} {
X list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
X} {1 xaAAaAAay}
Xtest regexp-8.2 {case conversion in regsub} {
X list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
X} {1 xaAAaAAay}
Xtest regexp-8.3 {case conversion in regsub} {
X set foo 123
X list [regsub a(a+) xaAAaAAay & foo] $foo
X} {0 123}
X
Xtest regexp-9.1 {-all option to regsub} {
X set foo 86
X list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
X} {1 a|xxx|b|xx|c|x|d|x|}
Xtest regexp-9.2 {-all option to regsub} {
X set foo 86
X list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
X} {1 a|XxX|b|xx|c|X|d|x|}
Xtest regexp-9.3 {-all option to regsub} {
X set foo 86
X list [regsub x+ axxxbxxcxdx |&| foo] $foo
X} {1 a|xxx|bxxcxdx}
Xtest regexp-9.4 {-all option to regsub} {
X set foo 86
X list [regsub -all bc axxxbxxcxdx |&| foo] $foo
X} {0 86}
Xtest regexp-9.5 {-all option to regsub} {
X set foo xxx
X list [regsub -all node "node node more" yy foo] $foo
X} {1 {yy yy more}}
X
Xtest regexp-10.1 {regsub errors} {
X list [catch {regsub a b c} msg] $msg
X} {1 {wrong # args: should be "regsub ?-nocase? ?-all? exp string subSpec varName"}}
Xtest regexp-10.2 {regsub errors} {
X list [catch {regsub -nocase a b c} msg] $msg
X} {1 {wrong # args: should be "regsub ?-nocase? ?-all? exp string subSpec varName"}}
Xtest regexp-10.3 {regsub errors} {
X list [catch {regsub -nocase -all a b c} msg] $msg
X} {1 {wrong # args: should be "regsub ?-nocase? ?-all? exp string subSpec varName"}}
Xtest regexp-10.4 {regsub errors} {
X list [catch {regsub a b c d e f} msg] $msg
X} {1 {wrong # args: should be "regsub ?-nocase? ?-all? exp string subSpec varName"}}
Xtest regexp-10.5 {regsub errors} {
X list [catch {regsub -nocas a b c} msg] $msg
X} {0 0}
Xtest regexp-10.6 {regsub errors} {
X list [catch {regsub -nocase a( b c d} msg] $msg
X} {1 {couldn't compile regular expression pattern: unmatched ()}}
Xtest regexp-10.7 {regsub errors} {
X list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
X} {1 {couldn't set variable "f1(f2)"}}
END_OF_FILE
if test 9482 -ne `wc -c <'tcl6.1/tests/regexp.test'`; then
echo shar: \"'tcl6.1/tests/regexp.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/regexp.test'
fi
echo shar: End of archive 7 $of 33$.
cp /dev/null ark7isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:28:31 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 76
Archive-name: tcl/part08
Environment: UNIX

# "End of archive 8 (of 33)."
# Contents: tcl6.1/README tcl6.1/doc/SetResult.man
# tcl6.1/doc/SetVar.man tcl6.1/tests/string.test
# Wrapped by karl@one on Tue Nov 12 19:44:17 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/README' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/README'\"
else
echo shar: Extracting \"'tcl6.1/README'\" $10992 characters$
sed "s/^X//" >'tcl6.1/README' <<'END_OF_FILE'
XTcl
X
Xby John Ousterhout
XUniversity of California at Berkeley
Xou...@sprite.berkeley.edu
X
X1. Introduction
X---------------
X
XThis directory contains the sources and documentation for Tcl, an
Xembeddable tool command language. The information here corresponds
Xto release 6.1. The 6.x releases of Tcl are different in many ways
Xfrom releases before 6.0. See below for general information on potential
Xincompatibilies. The file "changes" has a complete list of all changes
Xmade to Tcl, with incompatible changes specially marked. Tcl 6.1 has
Xonly one incompatible change relative to 6.0, concerning the "regexp"
Xcommand.
X
XFor an introduction to the facilities provided by Tcl, see the paper
X``Tcl: An Embeddable Command Language'', in the Proceedings of the
X1990 Winter USENIX Conference. A copy of that paper is included here
Xin Postscript form in the file "doc/usenix.ps" and in text form in the
Xfile "doc/usenix.text". However, the paper corresponds to a much
Xearlier version of Tcl (approximately version 3.0), so some details
Xof the paper may not be correct anymore and there are many new features
Xnot documented in the paper.
X
X2. Documentation
X----------------
X
XThe "doc" subdirectory contains a complete set of manual entries
Xfor Tcl. The file "doc/Tcl.man" gives an overall description of the
XTcl language and describes the core Tcl commands. The other ".man"
Xfiles in "doc" describe the library procedures that Tcl provides for
XTcl-based applications. Read the "Tcl" man page first. To print any
Xof the man pages, cd to the "doc" directory and invoke your favorite
Xvariant of troff using the normal -man macros, for example
X
X ditroff -man <file>
X
Xwhere <file> is the name of the man page you'd like to print.
X
X3. Machines supported
X---------------------
X
XIf you follow the directions below, this release should compile
Xand run on the following configurations either "out of the box"
Xor with only trivial changes:
X
X - Sun-3's, Sun-4's, SPARCstation-1's and SPARCstation-2's running
X many variants of SunOS, such as 4.1.
X - DECstation-3100's and DECstation-5000's running many versions of
X Ultrix, such as 2.0 and 4.2.
X - DEC VAXes running many versions of Ultrix or BSD UNIX.
X - Intel 386 based systems running SCO Unix 3.2v2.
X - Intel 386 based systems running SCO Xenix 2.3.3.
X - Intel 386 based systems running Bell-Tech (now Intel) Unix 3.2.0.
X - Silicon Graphics systems running IRIX 4.0.
X - Various H-P machines running versions of HP-UX such as 7.05
X
XIf you find problems running Tcl on any of the above configurations,
Xplease let me know. Also, if you are able to compile Tcl and run the
Xtest suite successfully on configurations not listed above, please
Xlet me know and tell me what changes, if any, you needed to make to
Xdo it. I'd like to keep the above list up-to-date and continue to
Ximprove the portability of Tcl.
X
X4. Compiling Tcl
X----------------
X
XTo compile Tcl on any of the configurations listed above, or systems
Xsimilar to them, do the following:
X
X (a) Edit the "set" commands at the beginning of the file "config"
X if necessary to correspond to your system configuration (they
X should already be right for most versions of Unix).
X
X (b) Type "./config" in the top-level directory. "Config" is a script
X that pokes around in your system to see if certain almost-standard
X things are missing (header files, library procedures, etc.);
X if your system doesn't seem to have them, it configures Tcl to
X use its own copies of these things instead (Tcl's copies are
X kept in the "compat" subdirectory). Config prints out messages
X for all the substitutions it made. You can ignore any of the
X messages unless they say "ERROR!!"; in this case something is
X fundamentally wrong and the config script couldn't handle your
X system configuration.
X
X (c) Type "make" to compile the library. This will create the Tcl
X library in "libtcl.a". The Makefile should work without any
X modifications but you may wish to personalize it, e.g. to
X turn on compiler optimization.
X
X (d) If the combination of "config" and "make" doesn't work for you,
X then I suggest the following approach:
X - Start again with a fresh copy of the distribution.
X - Set the #defines that appear at the very front of
X tclUnix.h (before the first #include) to correspond
X to your system.
X - Modify Makefile to set CC, CFLAGS, etc. for your system.
X - If things don't compile or don't link, then you may need
X to copy some of the .c or .h files from the "compat"
X directory into the main Tcl directory to compensate for
X files missing from your system. Modify the COMPAT_OBJS
X definition in Makefile to include a .o name for each of
X the .c files that you copied up from the compat directory.
X
X (e) Create a directory /usr/local/lib/tcl and copy all the files
X from the "library" subdirectory to /usr/local/lib/tcl. Or,
X you can use some other directory as library, but you'll need
X to modify the Makefile to reflect this fact (change the
X TCL_LIBRARY definition).
X
X (f) Type "make tclTest", which will create a simple test program that
X you can use to try out the Tcl facilities. TclTest is just a
X main-program sandwich around the Tcl library. It reads standard
X input until it reaches the end of a line where parentheses and
X backslashes are balanced, then sends everything it's read to the
X Tcl interpreter. When the Tcl interpreter returns, tclTest prints
X the return value or error message. TclTest defines a few other
X additional commands, most notably:
X
X echo arg arg ...
X
X The "echo" command prints its arguments on standard output,
X separated by spaces.
X
X5. Test suite
X-------------
X
XThere is a relatively complete test suite for all of the Tcl core in
Xthe subdirectory "tests". To use it, run tclTest in this directory
Xand then type the following commands:
X
X cd tests
X source all
X
XYou should then see a printout of the test files processed. If any
Xerrors occur, you'll see a much more substantial printout for each
Xerror. Tcl should pass the test suite cleanly on all of the systems
Xlisted in Section 3. See the README file in the "tests" directory
Xfor more information on the test suite.
X
X6. Compiling on non-UNIX systems
X--------------------------------
X
XThe Tcl features that depend on system calls peculiar to UNIX (stat,
Xfork, exec, times, etc.) are now separate from the main body of Tcl,
Xwhich only requires a few generic library procedures such as malloc
Xand strcpy. Thus it should be relatively easy to compile Tcl for
Xthese machines, although a number of UNIX-specific commands will
Xbe absent (e.g. exec, time, and glob). See the comments at the
Xtop of Makefile for information on how to compile without the UNIX
Xfeatures.
X
X7. Major changes for release 6.0
X--------------------------------
X
XVersion 6.0 is a major new release with a number of improvements over
Xearlier releases and several changes that are not backward compatible.
XIf you've been using earlier releases of Tcl you'll need to make changes
Xto both your Tcl scripts and to your C application code in order to
Xuse this release. In general, a change in the major release number
X(e.g. from 5.x to 6.x) means that there are significant incompatibilities
Xbetween the new release and old releases.
X
XA complete list of all changes to Tcl can be found in the file "changes",
Xin chronological order. In addition, the manual entries contain change
Xbars in the right margins for all recent changes (the "changes" file
Xindicates the last time that all the change bars were removed from the
Xdocumentation). Here is a short list of some of the most significant
Xenhancements in Tcl 6.0:
X
X - Floating-point support in expressions
X - Associative arrays
X - Support in "exec" for pipelines, background, redirection
X - Support for regular expressions and other forms of string manipulation
X - New commands for file I/O (open, close, gets, puts, etc.)
X - Support for demand-loading of Tcl scripts
X - Several new list-manipulation commands
X - Improved portability, especially to System-V systems
X - ANSI C function prototypes
X - Improved test suite
X - Many other new commands
X
XHere is a list of the most important incompatibilities introduced by
XTcl 6.0:
X
X - Newlines inside bracketed commands used to be treated as word
X separators; they are now treated as command separators (this is
X consistent with the way newlines are treated elsewhere in Tcl).
X - The order of arguments to the "file" command has been changed so
X that the "option" argument is first instead of second (this makes
X "file" consistent with all other Tcl commands).
X - The "index", "length", "print", and "range" commands have all been
X deleted (similar effects can be achieved using other commands).
X - Command abbreviations are no longer supported directly (but they
X can be added using the "unknown" command and are supported in the
X library version of "unknown").
X - The "<" notation in "exec" has been changed to "<<".
X - The "exec" command deletes the last character of program output if
X it is a newline (in most cases this makes it easier to parse the
X program output).
X - The variable-tracing mechanism has been totally changed to accommodate
X associative arrays; most of the C interfaces to Tcl variables have
X changed at least slightly.
X - The C interfaces to the expression evaluator and to Tcl_Eval have
X changed slightly.
X
X8. Special thanks
X-----------------
X
XMark Diekhans and Karl Lehenbauer of Santa Cruz Operation deserve special
Xthanks for all their help during the development of Tcl 6.0. Many of the
Xnew features in Tcl 6.0 were inspired by an enhanced version of Tcl 3.3
Xcalled Extended Tcl 4.0, which was created by Mark, Karl, and Peter
Xda Silva. Mark and Karl explained these features to me and provided
Xexcellent (and challenging) feedback during the 6.0 development process.
XThey were also a great help in finding and fixing portability problems.
XWithout their ideas and assistance Tcl 6.0 would be much less powerful.
X
X9. Support
X----------
X
XThere is no official support organization for Tcl, and I can't promise
Xto provide much hand-holding to people learning Tcl. However, I'm very
Xinterested in receiving bug reports and suggestions for improvements.
XBugs usually get fixed quickly (particularly if they are serious), but
Xenhancements may take a while and may not happen at all unless there
Xis widespread support for them.
X
X10. Tcl mailing list
X--------------------
X
XI maintain a mail alias of people interested in exchanging ideas and
Xexperiences with Tcl and Tcl-based applications (such as the Tk
Xtoolkit). If you would like to join the mailing list, send a
Xrequest to "tcl-r...@sprite.berkeley.edu". Traffic on the
Xmailing list is moderate to low: a few messages per week, on average.
XThere will be a "comp.lang.tcl" newsgroup soon.
END_OF_FILE
if test 10992 -ne `wc -c <'tcl6.1/README'`; then
echo shar: \"'tcl6.1/README'\" unpacked with wrong size!
fi
# end of 'tcl6.1/README'
fi
if test -f 'tcl6.1/doc/SetResult.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/SetResult.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/SetResult.man'\" $9903 characters$
sed "s/^X//" >'tcl6.1/doc/SetResult.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/SetResult.man,v 1.6 91/09/04 16:37:49 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_SetResult tcl
X.BS
X.SH NAME
XTcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

X.VS
X\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR)
X.VE
X.sp
X\fBTcl_AppendResult(\fIinterp, string, string, ... , \fB(char *) NULL\fR)
X.sp
X.VS
X\fBTcl_AppendElement\fR(\fIinterp, string, noSep\fR)
X.sp
X\fBTcl_ResetResult\fR(\fIinterp\fR)
X.sp
X\fBTcl_FreeResult\fR(\fIinterp\fR)
X.VE
X.SH ARGUMENTS
X.AS Tcl_FreeProc freeProc
X.AP Tcl_Interp *interp out
XInterpreter whose result is to be modified.
X.AP char *string in
XString value to be become result for \fIinterp\fR or to be
Xappended to existing result.
X.AP Tcl_FreeProc freeProc in
X.VS
XAddress of procedure to call to release storage at
X\fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or
X\fBTCL_VOLATILE\fR.
X.AP int noSep in
XIf non-zero then don't output a space character before this element,
Xeven if the element isn't the first thing in the result string.

X.VE
X.BE
X
X.SH DESCRIPTION
X.PP

XThe procedures described here are utilities for setting the
Xresult/error string in a Tcl interpreter.
X.PP
X\fBTcl_SetResult\fR
Xarranges for \fIstring\fR to be the return string for the current Tcl
Xcommand in \fIinterp\fR, replacing any existing result.
X.VS
XIf \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR
Xrefers to an area of static storage that is guaranteed not to be
Xmodified until at least the next call to \fBTcl_Eval\fR.
XIf \fIfreeProc\fR
Xis \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call
Xto \fBmalloc()\fR and is now the property of the Tcl system.
X\fBTcl_SetResult\fR will arrange for the string's storage to be
Xreleased by calling \fBfree()\fR when it is no longer needed.
XIf \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR
Xpoints to an area of memory that is likely to be overwritten when
X\fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame).
XIn this case \fBTcl_SetResult\fR will make a copy of the string in
Xdynamically allocated storage and arrange for the copy to be the
Xreturn string for the current Tcl command.
X.PP
XIf \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR,
X\fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address
Xof a procedure that Tcl should call to free the string.
XThis allows applications to use non-standard storage allocators.
XWhen Tcl no longer needs the storage for the string, it will
Xcall \fIfreeProc\fR. \fIFreeProc\fR should have arguments and
Xresult that match the type \fBTcl_FreeProc\fR:
X.nf
X.RS
X

Xtypedef void Tcl_FreeProc(char *\fIblockPtr\fR);
X

X.RE
X.fi
XWhen \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
Xthe value of \fIstring\fR passed to \fBTcl_SetResult\fR.
X.VE
X.PP
XIf \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored
Xand \fBTcl_SetResult\fR
Xre-initializes \fIinterp\fR's result to point to the pre-allocated result
Xarea, with an empty string in the result area.
X.PP
X.VS
XIf \fBTcl_SetResult\fR is called at a time when \fIinterp\fR holds a
Xresult, \fBTcl_SetResult\fR does whatever is necessary to dispose
Xof the old result (see the \fBTcl_Interp\fR manual entry for details
Xon this).
X.VE
X.PP
X\fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces.
XIt takes each of its \fIstring\fR arguments and appends them in order
Xto the current result associated with \fIinterp\fR.
X.VS
XIf the result is in its initialized empty state (e.g. a command procedure
Xwas just invoked or \fBTcl_ResetResult\fR was just called),
Xthen \fBTcl_AppendResult\fR sets the result to the concatenation of
Xits \fIstring\fR arguments.
X.VE
X\fBTcl_AppendResult\fR may be called repeatedly as additional pieces
Xof the result are produced.
X\fBTcl_AppendResult\fR takes care of all the
Xstorage management issues associated with managing \fIinterp\fR's
Xresult, such as allocating a larger result area if necessary.
XAny number of \fIstring\fR arguments may be passed in a single
Xcall; the last argument in the list must be a NULL pointer.
X.PP
X\fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in
X.VS
Xthat it allows results to be built up in pieces.
XHowever, \fBTcl_AppendElement\fR takes only a single \fIstring\fR
Xargument and it appends that argument to the current result
Xas a proper Tcl list element.
X\fBTcl_AppendElement\fR adds backslashes or braces if necessary
Xto ensure that \fIinterp\fR's result can be parsed as a list and that
X\fIstring\fR will be extracted as a single element.
XUnder normal conditions, \fBTcl_AppendElement\fR will add a space
Xcharacter to \fIinterp\fR's result just before adding the new
Xlist element, so that the list elements in the result are properly
Xseparated.
XHowever, if \fIinterp\fR's result is empty when \fBTcl_AppendElement\fR
Xis called, or if the \fInoSep\fR argument is 1, then no space
Xis added.
X.PP
X\fBTcl_ResetResult\fR clears the result for \fIinterp\fR,
Xfreeing the memory associated with it if the current result was
Xdynamically allocated.
XIt leaves the result in its normal initialized state with
X\fIinterp->result\fR pointing to a static buffer containing
X\fBTCL_RESULT_SIZE\fR characters, of which the first character
Xis zero.
X\fBTcl_ResetResult\fR also clears the error state managed by
X\fBTcl_AddErrorInfo\fR and \fBTcl_SetErrorCode\fR.
X.PP
X\fBTcl_FreeResult\fR is a macro that performs part of the work
Xof \fBTcl_ResetResult\fR.
XIt frees up the memory associated with \fIinterp\fR's result
Xand sets \fIinterp->freeProc\fR to zero, but it doesn't
Xchange \fIinterp->result\fR or clear error state.
X\fBTcl_FreeResult\fR is most commonly used when a procedure
Xis about to replace one result value with another.

X.VE
X
X.SH "SEE ALSO"

XTcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_Interp
X
X.SH KEYWORDS
Xappend, command, element, list, result, return value, interpreter
END_OF_FILE
if test 9903 -ne `wc -c <'tcl6.1/doc/SetResult.man'`; then
echo shar: \"'tcl6.1/doc/SetResult.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/SetResult.man'
fi
if test -f 'tcl6.1/doc/SetVar.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/SetVar.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/SetVar.man'\" $9653 characters$
sed "s/^X//" >'tcl6.1/doc/SetVar.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/man/RCS/SetVar.man,v 1.7 91/11/01 14:40:53 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_SetVar tcl
X.BS
X.VS
X.SH NAME
XTcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables

X.SH SYNOPSIS
X.nf
X\fB#include <tcl.h>\fR
X.sp

Xchar *
X\fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR)
X.sp
Xchar *
X\fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR)
X.sp
Xchar *
X\fBTcl_GetVar\fR(\fIinterp, varName, flags\fR)
X.sp
Xchar *
X\fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR)
X.sp
Xint
X\fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR)
X.sp
Xint
X\fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR)
X.SH ARGUMENTS

X.AS Tcl_Interp *interp
X.AP Tcl_Interp *interp in

XInterpreter containing variable.
X.AP char *varName in
XName of variable. May refer to a scalar variable or an element of
Xan array variable.
X.AP char *newValue in
XNew value for variable.
X.AP int flags in
XOR-ed combination of bits providing additional information for
Xoperation. See below for valid values.
X.AP char *name1 in
XName of scalar variable, or name of array variable if \fIname2\fR
Xis non-NULL.
X.AP char *name2 in
XIf non-NULL, gives name of element within array and \fIname1\fR
Xmust refer to an array variable.

X.BE
X
X.SH DESCRIPTION
X.PP

XThese procedures may be used to create, modify, read, and delete
XTcl variables from C code.
X\fBTcl_SetVar\fR and \fBTcl_SetVar2\fR will create a new variable
Xor modify an existing one.
XBoth of these procedures set the given variable to the value
Xgiven by \fInewValue\fR, and they return a pointer to a
Xcopy of the variable's new value, which is stored in Tcl's
Xvariable structure.
XTcl keeps a private copy of the variable's value, so the caller
Xmay change \fInewValue\fR after these procedures return without
Xaffecting the value of the variable.
XIf an error occurs in setting the variable (e.g. an array
Xvariable is referenced without giving an index into the array),
Xthen NULL is returned.
X.PP
XThe name of the variable may be specified in either of two ways.
XIf \fBTcl_SetVar\fR is called, the variable name is given as
Xa single string, \fIvarName\fR.
XIf \fIvarName\fR contains an open parenthesis and ends with a
Xclose parenthesis, then the value between the parentheses is
Xtreated as an index (which can have any string value) and
Xthe characters before the first open
Xparenthesis are treated as the name of an array variable.
XIf \fIvarName\fR doesn't have parentheses as described above, then
Xthe entire string is treated as the name of a scalar variable.
XIf \fBTcl_SetVar2\fR is called, then the array name and index
Xhave been separated by the caller into two separate strings,
X\fIname1\fR and \fIname2\fR respectively; if \fIname2\fR is
Xzero it means that a scalar variable is being referenced.
X.PP
XThe \fIflags\fR argument may be used to specify any of several
Xoptions to the procedures.
XIt consists of an OR-ed combination of any of the following
Xbits:
X.IP TCL_GLOBAL_ONLY
XUnder normal circumstances the procedures look up variables
Xat the current level of procedure call for \fIinterp\fR, or
Xat global level if there is no call active.
XHowever, if this bit is set in \fIflags\fR then the variable
Xis looked up at global level even if there is a procedure
Xcall active.
X.IP TCL_LEAVE_ERR_MSG
XIf an error is returned and this bit is set in \fIflags\fR, then
Xan error message will be left in \fI\%interp->result\fR. If this
Xflag bit isn't set then no error message is left (\fI\%interp->result\fR
Xwill not be modified).
X.IP TCL_APPEND_VALUE
XIf this bit is set then \fInewValue\fR is appended to the current
Xvalue, instead of replacing it.
XIf the variable is currently undefined, then this bit is ignored.
X.IP TCL_LIST_ELEMENT
XIf this bit is set, then \fInewValue\fR is converted to a valid
XTcl list element before setting (or appending to) the variable.
XIf the list element is being appended to an non-empty value, then
Xa space character is appended before the new list element to
Xseparate it from previous elements.
X.IP TCL_NO_SPACE
XIf this bit is set, it prevents the output of a separating space
Xcharacter in TCL_LIST_ELEMENT appends.
XThis bit has no effect if the TCL_LIST_ELEMENT bit isn't set.
X.PP
X\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value
Xof a variable.
XThe arguments to these procedures are treated in the same way
Xas the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR.
XUnder normal circumstances, the return value is a pointer
Xto the variable's value (which is stored in Tcl's variable
Xstructure and will not change before the next call to \fBTcl_SetVar\fR
Xor \fBTcl_SetVar2\fR).
XThe only bits of \fIflags\fR that are used are TCL_GLOBAL_ONLY
Xand TCL_LEAVE_ERR_MSG, both of
Xwhich have
Xthe same meaning as for \fBTcl_SetVar\fR.
XIf an error occurs in reading the variable (e.g. the variable
Xdoesn't exist or an array element is specified for a scalar
Xvariable), then NULL is returned.
X.PP
X\fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove
Xa variable, so that future calls to \fBTcl_GetVar\fR or \fBTcl_GetVar2\fR
Xfor the variable will return an error.
XThe arguments to these procedures are treated in the same way
Xas the arguments to \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR.
XIf the variable is successfully removed then 0 is returned.
XIf the variable cannot be removed because it doesn't exist
Xor because a trace is active for it, then -1 is returned.
XIf an array element is specified, the given element is removed
Xbut the array remains.
XIf an array name is specified without an index, then the entire
Xarray is removed.
X
X.SH "SEE ALSO"
XTcl_TraceVar
X
X.SH KEYWORDS
Xarray, interpreter, scalar, set, unset, variable
X.VE
END_OF_FILE
if test 9653 -ne `wc -c <'tcl6.1/doc/SetVar.man'`; then
echo shar: \"'tcl6.1/doc/SetVar.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/SetVar.man'
fi
if test -f 'tcl6.1/tests/string.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/string.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/string.test'\" $9785 characters$
sed "s/^X//" >'tcl6.1/tests/string.test' <<'END_OF_FILE'
X# Commands covered: string

X# $Header: /sprite/src/lib/tcl/tests/RCS/string.test,v 1.5 91/09/11 16:45:17 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest string-1.1 {string compare} {
X string compare abcde abdef
X} -1
Xtest string-1.2 {string compare} {
X string c abcde ABCDE
X} 1
Xtest string-1.3 {string compare} {
X string compare abcde abcde
X} 0
Xtest string-1.4 {string compare} {
X list [catch {string compare a} msg] $msg
X} {1 {wrong # args: should be "string compare string1 string2"}}
Xtest string-1.5 {string compare} {
X list [catch {string compare a b c} msg] $msg
X} {1 {wrong # args: should be "string compare string1 string2"}}
X
Xtest string-2.1 {string first} {
X string first bq abcdefgbcefgbqrs
X} 12
Xtest string-2.2 {string first} {
X string fir bcd abcdefgbcefgbqrs
X} 1
Xtest string-2.3 {string first} {
X string f b abcdefgbcefgbqrs
X} 1
Xtest string-2.4 {string first} {
X string first xxx x123xx345xxx789xxx012
X} 9
Xtest string-2.5 {string first} {
X list [catch {string first a} msg] $msg
X} {1 {wrong # args: should be "string first string1 string2"}}
Xtest string-2.6 {string first} {
X list [catch {string first a b c} msg] $msg
X} {1 {wrong # args: should be "string first string1 string2"}}
X
Xtest string-3.1 {string index} {
X string index abcde 0
X} a
Xtest string-3.2 {string index} {
X string i abcde 4
X} e
Xtest string-3.3 {string index} {
X string index abcde 5
X} {}
Xtest string-3.4 {string index} {
X list [catch {string index abcde -10} msg] $msg
X} {0 {}}
Xtest string-3.5 {string index} {
X list [catch {string index} msg] $msg
X} {1 {wrong # args: should be "string index string charIndex"}}
Xtest string-3.6 {string index} {
X list [catch {string index a b c} msg] $msg
X} {1 {wrong # args: should be "string index string charIndex"}}
Xtest string-3.7 {string index} {
X list [catch {string index a xyz} msg] $msg
X} {1 {expected integer but got "xyz"}}
X
Xtest string-4.1 {string last} {
X string la xxx xxxx123xx345x678
X} 1
Xtest string-4.2 {string last} {
X string last xx xxxx123xx345x678
X} 7
Xtest string-4.3 {string last} {
X string las x xxxx123xx345x678
X} 12
Xtest string-4.4 {string last} {
X list [catch {string last a} msg] $msg
X} {1 {wrong # args: should be "string last string1 string2"}}
Xtest string-4.5 {string last} {
X list [catch {string last a b c} msg] $msg
X} {1 {wrong # args: should be "string last string1 string2"}}
X
Xtest string-5.1 {string length} {
X string length "a little string"
X} 15
Xtest string-5.2 {string length} {
X string le ""
X} 0
Xtest string-5.3 {string length} {
X list [catch {string length} msg] $msg
X} {1 {wrong # args: should be "string length string"}}
Xtest string-5.4 {string length} {
X list [catch {string length a b} msg] $msg
X} {1 {wrong # args: should be "string length string"}}
X
Xtest string-6.1 {string match} {
X string match abc abc
X} 1
Xtest string-6.2 {string match} {
X string m abc abd
X} 0
Xtest string-6.3 {string match} {
X string match ab*c abc
X} 1
Xtest string-6.4 {string match} {
X string match ab**c abc
X} 1
Xtest string-6.5 {string match} {
X string match ab* abcdef
X} 1
Xtest string-6.6 {string match} {
X string match *c abc
X} 1
Xtest string-6.7 {string match} {
X string match *3*6*9 0123456789
X} 1
Xtest string-6.8 {string match} {
X string match *3*6*9 01234567890
X} 0
Xtest string-6.9 {string match} {
X string match a?c abc
X} 1
Xtest string-6.10 {string match} {
X string match a??c abc
X} 0
Xtest string-6.11 {string match} {
X string match ?1??4???8? 0123456789
X} 1
Xtest string-6.12 {string match} {
X string match {[abc]bc} abc
X} 1
Xtest string-6.13 {string match} {
X string match {a[abc]c} abc
X} 1
Xtest string-6.14 {string match} {
X string match {a[xyz]c} abc
X} 0
Xtest string-6.15 {string match} {
X string match {12[2-7]45} 12345
X} 1
Xtest string-6.16 {string match} {
X string match {12[ab2-4cd]45} 12345
X} 1
Xtest string-6.17 {string match} {
X string match {12[ab2-4cd]45} 12b45
X} 1
Xtest string-6.18 {string match} {
X string match {12[ab2-4cd]45} 12d45
X} 1
Xtest string-6.19 {string match} {
X string match {12[ab2-4cd]45} 12145
X} 0
Xtest string-6.20 {string match} {
X string match {12[ab2-4cd]45} 12545
X} 0
Xtest string-6.21 {string match} {
X string match {a\*b} a*b
X} 1
Xtest string-6.22 {string match} {
X string match {a\*b} ab
X} 0
Xtest string-6.23 {string match} {
X string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
X} 1
Xtest string-6.24 {string match} {
X list [catch {string match a} msg] $msg
X} {1 {wrong # args: should be "string match pattern string"}}
Xtest string-6.25 {string match} {
X list [catch {string match a b c} msg] $msg
X} {1 {wrong # args: should be "string match pattern string"}}
X
Xtest string-7.1 {string range} {
X string range abcdefghijklmnop 2 14
X} {cdefghijklmno}
Xtest string-7.2 {string range} {
X string range abcdefghijklmnop 7 1000
X} {hijklmnop}
Xtest string-7.3 {string range} {
X string range abcdefghijklmnop 10 e
X} {klmnop}
Xtest string-7.4 {string range} {
X string range abcdefghijklmnop 10 9
X} {}
Xtest string-7.5 {string range} {
X string range abcdefghijklmnop -3 2
X} {abc}
Xtest string-7.6 {string range} {
X string range abcdefghijklmnop -3 -2
X} {}
Xtest string-7.7 {string range} {
X string range abcdefghijklmnop 1000 1010
X} {}
Xtest string-7.8 {string range} {
X string range abcdefghijklmnop -100 end
X} {abcdefghijklmnop}
Xtest string-7.9 {string range} {
X list [catch {string range} msg] $msg
X} {1 {wrong # args: should be "string range string first last"}}
Xtest string-7.10 {string range} {
X list [catch {string range a 1} msg] $msg
X} {1 {wrong # args: should be "string range string first last"}}
Xtest string-7.11 {string range} {
X list [catch {string range a 1 2 3} msg] $msg
X} {1 {wrong # args: should be "string range string first last"}}
Xtest string-7.12 {string range} {
X list [catch {string range abc abc 1} msg] $msg

X} {1 {expected integer but got "abc"}}

Xtest string-7.13 {string range} {
X list [catch {string range abc 1 eof} msg] $msg
X} {1 {expected integer or "end" but got "eof"}}
X
Xtest string-8.1 {string trim} {
X string trim " XYZ "
X} {XYZ}
Xtest string-8.2 {string trim} {
X string trim "\t\nXYZ\t\n\r\n"
X} {XYZ}
Xtest string-8.3 {string trim} {
X string trim " A XYZ A "
X} {A XYZ A}
Xtest string-8.4 {string trim} {
X string trim "XXYYZZABC XXYYZZ" ZYX
X} {ABC }
Xtest string-8.5 {string trim} {
X string trim " \t\r "
X} {}
Xtest string-8.6 {string trim} {
X string trim {abcdefg} {}
X} {abcdefg}
Xtest string-8.7 {string trim} {
X string trim {}
X} {}
Xtest string-8.8 {string trim} {
X string trim ABC DEF
X} {ABC}
Xtest string-8.9 {string trim} {
X list [catch {string trim} msg] $msg
X} {1 {wrong # args: should be "string trim string ?chars?"}}
Xtest string-8.10 {string trim} {
X list [catch {string trim a b c} msg] $msg
X} {1 {wrong # args: should be "string trim string ?chars?"}}
X
Xtest string-9.1 {string trimleft} {
X string trimleft " XYZ "
X} {XYZ }
Xtest string-9.2 {string trimleft} {
X list [catch {string triml} msg] $msg
X} {1 {wrong # args: should be "string trimleft string ?chars?"}}
X
Xtest string-10.1 {string trimright} {
X string trimright " XYZ "
X} { XYZ}
Xtest string-10.2 {string trimright} {
X string trimright " "
X} {}
Xtest string-10.3 {string trimright} {
X string trimright ""
X} {}
Xtest string-10.4 {string trimright errors} {
X list [catch {string trimr} msg] $msg
X} {1 {wrong # args: should be "string trimright string ?chars?"}}
Xtest string-10.5 {string trimright errors} {
X list [catch {string trimg a} msg] $msg
X} {1 {bad option "trimg": should be compare, first, index, last, length, \
Xmatch, range, tolower, toupper, trim, trimleft, or trimright}}
X
Xtest string-11.1 {string tolower} {
X string tolower ABCDeF
X} {abcdef}
Xtest string-11.2 {string tolower} {
X string tolower "ABC XyZ"
X} {abc xyz}
Xtest string-11.3 {string tolower} {
X string tolower {123#$&*()}
X} {123#$&*()}
Xtest string-11.4 {string tolower} {
X list [catch {string tolower} msg] $msg
X} {1 {wrong # args: should be "string tolower string"}}
Xtest string-11.5 {string tolower} {
X list [catch {string tolower a b} msg] $msg
X} {1 {wrong # args: should be "string tolower string"}}
X
Xtest string-12.1 {string toupper} {
X string toupper abCDEf
X} {ABCDEF}
Xtest string-12.2 {string toupper} {
X string toupper "abc xYz"
X} {ABC XYZ}
Xtest string-12.3 {string toupper} {
X string toupper {123#$&*()}
X} {123#$&*()}
Xtest string-12.4 {string toupper} {
X list [catch {string toupper} msg] $msg
X} {1 {wrong # args: should be "string toupper string"}}
Xtest string-12.5 {string toupper} {
X list [catch {string toupper a b} msg] $msg
X} {1 {wrong # args: should be "string toupper string"}}
X
Xtest string-13.1 {error conditions} {
X list [catch {string gorp a b} msg] $msg
X} {1 {bad option "gorp": should be compare, first, index, last, length, \
Xmatch, range, tolower, toupper, trim, trimleft, or trimright}}
Xtest string-13.2 {error conditions} {
X list [catch {string} msg] $msg
X} {1 {wrong # args: should be "string option arg ?arg ...?"}}
END_OF_FILE
if test 9785 -ne `wc -c <'tcl6.1/tests/string.test'`; then
echo shar: \"'tcl6.1/tests/string.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/string.test'
fi
echo shar: End of archive 8 $of 33$.
cp /dev/null ark8isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:28:59 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 77
Archive-name: tcl/part09
Environment: UNIX

# "End of archive 9 (of 33)."
# Contents: tcl6.1/doc/library.man tcl6.1/tcl.h tcl6.1/tclEnv.c
# tcl6.1/tests/info.test
# Wrapped by karl@one on Tue Nov 12 19:44:18 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/library.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/library.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/library.man'\" $11210 characters$
sed "s/^X//" >'tcl6.1/doc/library.man' <<'END_OF_FILE'
X'\" Copyright 1991 Regents of the University of California

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/library.man,v 1.1 91/09/26 11:12:39 ouster Exp $ SPRITE (Berkeley)

X.de UL
X\\$1\l'|0\(ul'\\$2
X..
X.HS library tcl
X.BS
X.SH NAME
Xlibrary \- standard library of Tcl procedures
X.SH SYNOPSIS
X.VS
X.nf
X\fBauto_execok \fIcmd\fR
X\fBauto_load \fIcmd\fR
X\fBauto_mkindex \fIdir pattern\fR
X\fBauto_reset\fR
X\fBparray \fIarrayName\fR
X\fBunknown \fIcmd \fR?\fIarg arg ...\fR?
X.fi
X.BE
X
X.SH INTRODUCTION
X.PP
XTcl includes a library of Tcl procedures for commonly-needed functions.
XThe procedures defined in the Tcl library are generic ones suitable
Xfor use by many different applications.
XThe location of the Tcl library is returned by the \fBinfo library\fR
Xcommand.
XIn addition to the Tcl library, each application will normally have
Xits own library of support procedures as well; the location of this
Xlibrary is normally given by the value of the \fB$appLibrary\fR
Xglobal variable.
X.PP
XTo access the procedures in the Tcl library, an application should
Xsource the file \fBinit.tcl\fR in the library, for example with
Xthe Tcl command
X.DS
X\fBsource [info library]/init.tcl
X.DE
XThis will define the \fBunknown\fR procedure and arrange for the
Xother procedures to be loaded on-demand using the auto-load
Xmechanism defined below.
X
X.SH "COMMAND PROCEDURES"
X.PP
XThe following procedures are provided in the Tcl library:
X.TP
X\fBauto_execok \fIcmd\fR
XDetermines whether there is an executable file by the name \fIcmd\fR.
XThis command examines the directories in the current search path
X(given by the PATH enviornment variable) to see if there is an
Xexecutable file named \fIcmd\fR in any of those directories.
XIf so, it returns 1; if not it returns 0. \fBAuto_exec\fR
Xremembers information about previous searches in an array
Xnamed \fBauto_execs\fR; this avoids the path search in
Xfuture calls for the same \fIcmd\fR. The command \fBauto_reset\fR
Xmay be used to force \fBauto_execok\fR to forget its cached
Xinformation.
X.TP
X\fBauto_load \fIcmd\fR
XThis command attempts to load the definition for a Tcl procedure named
X\fIcmd\fR.
XTo do this, it searches an \fIauto-load path\fR, which is a list of
Xone or more directories.
XThe auto-load path is given by the global variable \fB$auto_path\fR
Xif it exists.
XIf there is no \fB$auto_path\fR variable, then the TCLLIBPATH environment
Xvariable is used, if it exists.
XOtherwise the auto-load path consists of just the Tcl library directory.
XWithin each directory in the auto-load path there must be a file
X\fBtclIndex\fR that describes the procedures defined in that directory
Xand the file in which each procedure is defined. The \fBtclIndex\fR
Xfile should be generated with the \fBauto_mkindex\fR command.
XIf \fIcmd\fR is found in an index file, then the appropriate
Xscript is \fBsource\fRd to create the procedure.
XThe \fBauto_load\fR command returns 1 if the script was successfully
Xsourced and \fIcmd\fR now exists.
XThe command returns 0 if there was no index entry for \fIcmd\fR
Xor if the script didn't actually define \fIcmd\fR (e.g. because
Xindex information is out of date).
XIf an error occurs while processing the script, then that error
Xis returned.
X\fBAuto_load\fR only reads the index information once and saves it
Xin the array \fBauto_index\fR; future calls to \fBauto_load\fR
Xcheck for \fIcmd\fR in the array rather than re-reading the index
Xfiles.
XThe cached index information may be deleted with the command
X\fBauto_reset\fR.
XThis will force the next \fBauto_load\fR command to reload the
Xindex database from disk.
X.TP
X\fBauto_mkindex \fIdir pattern\fR
XGenerates an index suitable for use by \fBauto_load\fR.
XThe command searches \fIdir\fR for all files whose names match
X\fIpattern\fR (matching is done with the \fBglob\fR command),
Xgenerates an index of all the Tcl command
Xprocedures defined in all the matching files, and stores the
Xindex information in a file named \fBtclIndex\fR in \fIdir\fR.
XFor example, the command
X.RS
X.DS
X\fBauto_mkindex foo *.tcl\fR
X.DE
X.LP
Xwill read all the \fB.tcl\fR files in subdirectory \fBfoo\fR
Xand generate a new index file \fBfoo/tclIndex\fR.
X.PP
X\fBAuto_mkindex\fR parses the Tcl scripts in a relatively
Xunsophisticated way: if any line contains the word \fBproc\fR
Xas its first characters then it is assumed to be a procedure
Xdefinition and the next word of the line is taken as the
Xprocedure's name.
XProcedure definitions that don't appear in this way (e.g. they
Xhave spaces before the \fBproc\fR) will not be indexed.
X.RE
X.TP
X\fBauto_reset\fR
XDestroys all the information cached by \fBauto_execok\fR and
X\fBauto_load\fR.
XThis information will be re-read from disk the next time it is
Xneeded.
X.TP
X\fBparray \fIarrayName\fR
XPrints on standard output the names and values of all the elements
Xin the array \fIarrayName\fR.
X\fBArrayName\fR must be a global array.
X.TP
X\fBunknown \fIcmd \fR?\fIarg arg ...\fR?
XThis procedure is invoked automatically by the Tcl interpreter
Xwhenever the name of a command doesn't exist.
XThe \fBunknown\fR procedure receives as its arguments the
Xname and arguments of the missing command.
X\fBUnknown\fR first calls \fBauto_load\fR to load a procedure for
Xthe command.
XIf this succeeds, then it executes the original command with its
Xoriginal arguments.
XIf the auto-load fails then \fBunknown\fR calls \fBauto_execok\fR
Xto see if there is an executable file by the name \fIcmd\fR.
XIf so, it invokes the Tcl \fBexec\fR command
Xwith \fIcmd\fR and all the \fIargs\fR as arguments.
XIf \fIcmd\fR can't be auto-executed, \fBunknown\fR checks to see if \fIcmd\fR is
Xa unique abbreviation for an existing Tcl command.
XIf so, it expands the command name and executes the command with
Xthe original arguments.
XFinally, if none of the above efforts has been able to execute
Xthe command, \fBunknown\fR generates an error return.
XIf the global variable \fBauto_noload\fR is defined, then the auto-load
Xstep is skipped.
XIf the global variable \fBauto_noexec\fR is defined then the
Xauto-exec step is skipped.
XUnder normal circumstances the return value from \fBunknown\fR
Xis the return value from the command that was eventually
Xexecuted.
X
X.SH "VARIABLES"
X.PP
XThe following global variables are defined or used by the procedures in
Xthe Tcl library:
X.TP
X\fBauto_execs\fR
XUsed by \fBauto_execok\fR to record information about whether
Xparticular commands exist as executable files.
X.TP
X\fBauto_index\fR
XUsed by \fBauto_load\fR to save the index information read from
Xdisk.
X.TP
X\fBauto_noexec\fR
XIf set to any value, then \fBunknown\fR will not attempt to auto-exec
Xany commands.
X.TP
X\fBauto_noload\fR
XIf set to any value, then \fBunknown\fR will not attempt to auto-load
Xany commands.
X.TP
X\fBauto_path\fR
XIf set, then it must contain a valid Tcl list giving directories to
Xsearch during auto-load operations.
X.TP
X\fBenv(TCLLIBPATH)\fR
XIf set, then it must contain a valid Tcl list giving directories to
Xsearch during auto-load operations.
XThis variable is only used if \fBauto_path\fR is not defined.
X.TP
X\fBunknown_active\fR
XThis variable is set by \fBunknown\fR to indicate that it is active.
XIt is used to detect errors where \fBunknown\fR recurses on itself
Xinfinitely.
XThe variable is unset before \fBunknown\fR returns.
X
X.SH KEYWORDS
Xauto-exec, auto-load, library, unknown
X.VE
END_OF_FILE
if test 11210 -ne `wc -c <'tcl6.1/doc/library.man'`; then
echo shar: \"'tcl6.1/doc/library.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/library.man'
fi
if test -f 'tcl6.1/tcl.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tcl.h'\"
else
echo shar: Extracting \"'tcl6.1/tcl.h'\" $11364 characters$
sed "s/^X//" >'tcl6.1/tcl.h' <<'END_OF_FILE'
X/*
X * tcl.h --
X *
X * This header file describes the externally-visible facilities
X * of the Tcl interpreter.
X *
X * Copyright 1987-1991 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 * $Header: /user6/ouster/tcl/RCS/tcl.h,v 1.76 91/11/05 10:12:30 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _TCL
X#define _TCL
X
X#define TCL_VERSION "6.1"
X
X/*
X * Definitions that allow this header file to be used either with or
X * without ANSI C features like function prototypes.
X */
X
X#undef _ANSI_ARGS_
X#undef const
X#if (defined(__STDC__) && !defined(NO_PROTOTYPE)) || defined(__cplusplus)
X# define _ANSI_ARGS_(x) x
X# define CONST const
X# ifdef __cplusplus
X# define VARARGS (...)
X# else
X# define VARARGS ()
X# endif
X#else
X# define _ANSI_ARGS_(x) ()
X# define CONST
X#endif
X
X#ifdef __cplusplus
X# define EXTERN extern "C"
X#else
X# define EXTERN extern
X#endif
X
X/*
X * Miscellaneous declarations (to allow Tcl to be used stand-alone,
X * without the rest of Sprite).
X */
X
X#ifndef NULL
X#define NULL 0
X#endif
X
X#ifndef _CLIENTDATA
Xtypedef int *ClientData;
X#define _CLIENTDATA
X#endif
X
X/*
X * Data structures defined opaquely in this module. The definitions
X * below just provide dummy types. A few fields are made visible in
X * Tcl_Interp structures, namely those for returning string values.
X * Note: any change to the Tcl_Interp definition below must be mirrored
X * in the "real" definition in tclInt.h.
X */
X
Xtypedef struct Tcl_Interp{
X char *result; /* Points to result string returned by last
X * command. */
X void (*freeProc) _ANSI_ARGS_((char *blockPtr));
X /* Zero means result is statically allocated.
X * If non-zero, gives address of procedure
X * to invoke to free the result. Must be
X * freed by Tcl_Eval before executing next
X * command. */
X int errorLine; /* When TCL_ERROR is returned, this gives
X * the line number within the command where
X * the error occurred (1 means first line). */
X} Tcl_Interp;
X
Xtypedef int *Tcl_Trace;
Xtypedef int *Tcl_CmdBuf;
X
X/*
X * When a TCL command returns, the string pointer interp->result points to
X * a string containing return information from the command. In addition,
X * the command procedure returns an integer value, which is one of the
X * following:
X *
X * TCL_OK Command completed normally; interp->result contains
X * the command's result.
X * TCL_ERROR The command couldn't be completed successfully;
X * interp->result describes what went wrong.
X * TCL_RETURN The command requests that the current procedure
X * return; interp->result contains the procedure's
X * return value.
X * TCL_BREAK The command requests that the innermost loop
X * be exited; interp->result is meaningless.
X * TCL_CONTINUE Go on to the next iteration of the current loop;
X * interp->result is meaninless.
X */
X
X#define TCL_OK 0
X#define TCL_ERROR 1
X#define TCL_RETURN 2
X#define TCL_BREAK 3
X#define TCL_CONTINUE 4
X
X#define TCL_RESULT_SIZE 199
X
X/*
X * Procedure types defined by Tcl:
X */
X
Xtypedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
Xtypedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, int argc, char *argv[]));
Xtypedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
X ClientData cmdClientData, int argc, char *argv[]));
Xtypedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
Xtypedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, char *name1, char *name2, int flags));
X
X/*
X * Flag values passed to Tcl_Eval (see the man page for details; also
X * see tclInt.h for additional flags that are only used internally by
X * Tcl):
X */
X
X#define TCL_BRACKET_TERM 1
X
X/*
X * Flag value passed to Tcl_RecordAndEval to request no evaluation
X * (record only).
X */
X
X#define TCL_NO_EVAL -1
X
X/*
X * Specil freeProc values that may be passed to Tcl_SetResult (see
X * the man page for details):
X */
X
X#define TCL_VOLATILE ((Tcl_FreeProc *) -1)
X#define TCL_STATIC ((Tcl_FreeProc *) 0)
X#define TCL_DYNAMIC ((Tcl_FreeProc *) free)
X
X/*
X * Flag values passed to variable-related procedures.
X */
X
X#define TCL_GLOBAL_ONLY 1
X#define TCL_APPEND_VALUE 2
X#define TCL_LIST_ELEMENT 4
X#define TCL_NO_SPACE 8
X#define TCL_TRACE_READS 0x10
X#define TCL_TRACE_WRITES 0x20
X#define TCL_TRACE_UNSETS 0x40
X#define TCL_TRACE_DESTROYED 0x80
X#define TCL_INTERP_DESTROYED 0x100
X#define TCL_LEAVE_ERR_MSG 0x200
X
X/*
X * Additional flag passed back to variable watchers. This flag must
X * not overlap any of the TCL_TRACE_* flags defined above or the
X * TRACE_* flags defined in tclInt.h.
X */
X
X#define TCL_VARIABLE_UNDEFINED 8
X
X/*
X * The following declarations either map ckalloc and ckfree to
X * malloc and free, or they map them to procedures with all sorts
X * of debugging hooks defined in tclCkalloc.c.
X */
X
X#ifdef TCL_MEM_DEBUG
X
XEXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size,
X char *file, int line));
XEXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr,
X char *file, int line));
X# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
X# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
X
X#else
X
X# define ckalloc(x) malloc(x)
X# define ckfree(x) free(x)
X
X#endif /* TCL_MEM_DEBUG */
X
X/*
X * Macro to free up result of interpreter.
X */
X
X#define Tcl_FreeResult(interp) \
X if ((interp)->freeProc != 0) { \
X if ((interp)->freeProc == (Tcl_FreeProc *) free) { \
X ckfree((interp)->result); \
X } else { \
X (*(interp)->freeProc)((interp)->result); \
X } \
X (interp)->freeProc = 0; \
X }
X
X/*
X * Exported Tcl procedures:
X */
X
XEXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int noSep));
XEXTERN void Tcl_AppendResult _ANSI_ARGS_(VARARGS);
XEXTERN char * Tcl_AssembleCmd _ANSI_ARGS_((Tcl_CmdBuf buffer,
X char *string));
XEXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp,
X char *message));
XEXTERN char Tcl_Backslash _ANSI_ARGS_((char *src,
X int *readPtr));
XEXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv));
XEXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src,
X char *dst, int flags));
XEXTERN Tcl_CmdBuf Tcl_CreateCmdBuf _ANSI_ARGS_((void));
XEXTERN void Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp,
X char *cmdName, Tcl_CmdProc *proc,
X ClientData clientData,
X Tcl_CmdDeleteProc *deleteProc));
XEXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
XEXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
X int argc, char **argv, int **pidArrayPtr,
X int *inPipePtr, int *outPipePtr,
X int *errFilePtr));
XEXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp,
X int level, Tcl_CmdTraceProc *proc,
X ClientData clientData));
XEXTERN void Tcl_DeleteCmdBuf _ANSI_ARGS_((Tcl_CmdBuf buffer));
XEXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp,
X char *cmdName));
XEXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp));
XEXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp,
X Tcl_Trace trace));
XEXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, int *pidPtr));
XEXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void));
XEXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd,
X int flags, char **termPtr));
XEXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp,
X char *fileName));
XEXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int *ptr));
XEXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, double *ptr));
XEXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, long *ptr));
XEXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp,
X char *string));
XEXTERN int Tcl_Fork _ANSI_ARGS_((void));
XEXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int *boolPtr));
XEXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, double *doublePtr));
XEXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int *intPtr));
XEXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, int flags));
XEXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, int flags));
XEXTERN void Tcl_InitHistory _ANSI_ARGS_((Tcl_Interp *interp));
XEXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp));
XEXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv));
XEXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, char **termPtr));
XEXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp,
X char *cmd, int flags));
XEXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
X#define Tcl_Return Tcl_SetResult
XEXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string,
X int *flagPtr));
XEXTERN void Tcl_SetErrorCode _ANSI_ARGS_(VARARGS);
XEXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, Tcl_FreeProc *freeProc));
XEXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, char *newValue, int flags));
XEXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, char *newValue,
X int flags));
XEXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig));
XEXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
XEXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp,
X char *list, int *argcPtr, char ***argvPtr));
XEXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string,
X char *pattern));
XEXTERN char * Tcl_TildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
X char *name));
XEXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, int flags, Tcl_VarTraceProc *proc,
X ClientData clientData));
XEXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, int flags,
X Tcl_VarTraceProc *proc, ClientData clientData));
XEXTERN char * Tcl_UnixError _ANSI_ARGS_((Tcl_Interp *interp));
XEXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, int flags));
XEXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, int flags));
XEXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, int flags, Tcl_VarTraceProc *proc,
X ClientData clientData));
XEXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, int flags,
X Tcl_VarTraceProc *proc, ClientData clientData));
XEXTERN int Tcl_VarEval _ANSI_ARGS_(VARARGS);
XEXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp,
X char *varName, int flags,
X Tcl_VarTraceProc *procPtr,
X ClientData prevClientData));
XEXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, int flags,
X Tcl_VarTraceProc *procPtr,
X ClientData prevClientData));
XEXTERN int Tcl_WaitPids _ANSI_ARGS_((int numPids, int *pidPtr,
X int *statusPtr));
X
X#endif /* _TCL */
END_OF_FILE
if test 11364 -ne `wc -c <'tcl6.1/tcl.h'`; then
echo shar: \"'tcl6.1/tcl.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tcl.h'
fi
if test -f 'tcl6.1/tclEnv.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclEnv.c'\"
else
echo shar: Extracting \"'tcl6.1/tclEnv.c'\" $11191 characters$
sed "s/^X//" >'tcl6.1/tclEnv.c' <<'END_OF_FILE'
X/*
X * tclEnv.c --
X *
X * Tcl support for environment variables, including a setenv
X * procedure.
X *

X * Copyright 1991 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 this copyright
X * notice appears 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/tclEnv.c,v 1.7 91/09/23 11:22:21 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X#include "tclUnix.h"
X
X/*
X * The structure below is used to keep track of all of the interpereters
X * for which we're managing the "env" array. It's needed so that they
X * can all be updated whenever an environment variable is changed
X * anywhere.
X */
X
Xtypedef struct EnvInterp {
X Tcl_Interp *interp; /* Interpreter for which we're managing
X * the env array. */
X struct EnvInterp *nextPtr; /* Next in list of all such interpreters,
X * or zero. */
X} EnvInterp;
X
Xstatic EnvInterp *firstInterpPtr;
X /* First in list of all managed interpreters,
X * or NULL if none. */
X
Xstatic int environSize = 0; /* Non-zero means that the all of the
X * environ-related information is malloc-ed
X * and the environ array itself has this
X * many total entries allocated to it (not
X * all may be in use at once). Zero means
X * that the environment array is in its
X * original static state. */
X
X/*
X * Declarations for local procedures defined in this file:
X */
X
Xstatic void EnvInit _ANSI_ARGS_((void));
Xstatic char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, char *name1, char *name2,
X int flags));
Xstatic int FindVariable _ANSI_ARGS_((char *name, int *lengthPtr));
Xvoid setenv _ANSI_ARGS_((char *name, char *value));
Xvoid unsetenv _ANSI_ARGS_((char *name));

X
X/*
X *----------------------------------------------------------------------
X *

X * TclSetupEnv --
X *
X * This procedure is invoked for an interpreter to make environment
X * variables accessible from that interpreter via the "env"
X * associative array.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The interpreter is added to a list of interpreters managed
X * by us, so that its view of envariables can be kept consistent
X * with the view in other interpreters. If this is the first
X * call to Tcl_SetupEnv, then additional initialization happens,
X * such as copying the environment to dynamically-allocated space
X * for ease of management.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTclSetupEnv(interp)
X Tcl_Interp *interp; /* Interpreter whose "env" array is to be
X * managed. */
X{
X EnvInterp *eiPtr;
X int i;
X
X /*
X * First, initialize our environment-related information, if
X * necessary.
X */
X
X if (environSize == 0) {
X EnvInit();
X }
X
X /*
X * Next, add the interpreter to the list of those that we manage.
X */
X
X eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp));
X eiPtr->interp = interp;
X eiPtr->nextPtr = firstInterpPtr;
X firstInterpPtr = eiPtr;
X
X /*
X * Store the environment variable values into the interpreter's
X * "env" array, and arrange for us to be notified on future
X * writes and unsets to that array.
X */
X
X (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
X for (i = 0; ; i++) {
X char *p, *p2;
X
X p = environ[i];
X if (p == NULL) {
X break;
X }
X for (p2 = p; *p2 != '='; p2++) {
X /* Empty loop body. */
X }
X *p2 = 0;
X (void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY);
X *p2 = '=';
X }
X Tcl_TraceVar2(interp, "env", (char *) NULL,
X TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
X EnvTraceProc, (ClientData) NULL);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * FindVariable --
X *
X * Locate the entry in environ for a given name.

X *
X * Results:

X * The return value is the index in environ of an entry with the
X * name "name", or -1 if there is no such entry. The integer at
X * *lengthPtr is filled in with the length of name (if a matching
X * entry is found) or the length of the environ array (if no matching
X * entry is found).

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XFindVariable(name, lengthPtr)
X char *name; /* Name of desired environment variable. */
X int *lengthPtr; /* Used to return length of name (for
X * successful searches) or number of non-NULL
X * entries in environ (for unsuccessful
X * searches). */
X{
X int i;
X register char *p1, *p2;
X
X for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
X for (p2 = name; *p2 == *p1; p1++, p2++) {
X /* NULL loop body. */
X }
X if ((*p1 == '=') && (*p2 == '\0')) {
X *lengthPtr = p2-name;
X return i;
X }
X }
X *lengthPtr = i;
X return -1;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * setenv --
X *
X * Set an environment variable, replacing an existing value
X * or creating a new variable if there doesn't exist a variable
X * by the given name.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The environ array gets updated, as do all of the interpreters
X * that we manage.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
Xsetenv(name, value)
X char *name; /* Name of variable whose value is to be
X * set. */
X char *value; /* New value for variable. */
X{
X int index, length, nameLength;
X char *p;
X EnvInterp *eiPtr;
X
X if (environSize == 0) {
X EnvInit();
X }
X
X /*
X * Figure out where the entry is going to go. If the name doesn't
X * already exist, enlarge the array if necessary to make room. If
X * the name exists, free its old entry.
X */
X
X index = FindVariable(name, &length);
X if (index == -1) {
X if ((length+2) > environSize) {
X char **newEnviron;
X
X newEnviron = (char **) ckalloc((unsigned)
X ((length+5) * sizeof(char *)));
X memcpy((VOID *) newEnviron, (VOID *) environ,
X length*sizeof(char *));
X ckfree((char *) environ);
X environ = newEnviron;
X environSize = length+5;
X }
X index = length;
X environ[index+1] = NULL;
X nameLength = strlen(name);
X } else {
X ckfree(environ[index]);
X nameLength = length;
X }
X
X /*
X * Create a new entry and enter it into the table.
X */
X
X p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
X environ[index] = p;
X strcpy(p, name);
X p += nameLength;
X *p = '=';
X strcpy(p+1, value);
X
X /*
X * Update all of the interpreters.
X */
X
X for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
X (void) Tcl_SetVar2(eiPtr->interp, "env", name, p+1, TCL_GLOBAL_ONLY);
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * unsetenv --
X *
X * Remove an environment variable, updating the "env" arrays
X * in all interpreters managed by us.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Interpreters are updated, as is environ.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
Xunsetenv(name)
X char *name; /* Name of variable to remove. */
X{
X int index, dummy;
X char **envPtr;
X EnvInterp *eiPtr;
X
X if (environSize == 0) {
X EnvInit();
X }
X
X /*
X * Update the environ array.
X */
X
X index = FindVariable(name, &dummy);
X if (index == -1) {
X return;
X }
X ckfree(environ[index]);
X for (envPtr = environ+index+1; ; envPtr++) {
X envPtr[-1] = *envPtr;
X if (*envPtr == NULL) {

X break;
X }
X }
X

X /*
X * Update all of the interpreters.
X */
X
X for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
X (void) Tcl_UnsetVar2(eiPtr->interp, "env", name, TCL_GLOBAL_ONLY);
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * EnvTraceProc --
X *
X * This procedure is invoked whenever an environment variable
X * is modified or deleted. It propagates the change to the
X * "environ" array and to any other interpreters for whom
X * we're managing an "env" array.

X *
X * Results:

X * Always returns NULL to indicate success.

X *
X * Side effects:

X * Environment variable changes get propagated. If the whole
X * "env" array is deleted, then we stop managing things for
X * this interpreter (usually this happens because the whole
X * interpreter is being deleted).

X *
X *----------------------------------------------------------------------
X */
X

X /* ARGSUSED */
Xstatic char *
XEnvTraceProc(clientData, interp, name1, name2, flags)
X ClientData clientData; /* Not used. */
X Tcl_Interp *interp; /* Interpreter whose "env" variable is
X * being modified. */
X char *name1; /* Better be "env". */
X char *name2; /* Name of variable being modified, or
X * NULL if whole array is being deleted. */
X int flags; /* Indicates what's happening. */
X{
X /*
X * First see if the whole "env" variable is being deleted. If
X * so, just forget about this interpreter.
X */
X
X if (name2 == NULL) {
X register EnvInterp *eiPtr, *prevPtr;
X
X if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED))
X != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) {
X panic("EnvTraceProc called with confusing arguments");
X }
X eiPtr = firstInterpPtr;
X if (eiPtr->interp == interp) {
X firstInterpPtr = eiPtr->nextPtr;
X } else {
X for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ;
X prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) {
X if (eiPtr == NULL) {
X panic("EnvTraceProc couldn't find interpreter");
X }
X if (eiPtr->interp == interp) {
X prevPtr->nextPtr = eiPtr->nextPtr;

X break;
X }
X }
X }

X ckfree((char *) eiPtr);

X return NULL;
X }
X

X /*
X * If a value is being set, call setenv to do all of the work.
X */
X
X if (flags & TCL_TRACE_WRITES) {
X setenv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY));
X }
X
X if (flags & TCL_TRACE_UNSETS) {
X unsetenv(name2);
X }

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * EnvInit --
X *
X * This procedure is called to initialize our management
X * of the environ array.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Environ gets copied to malloc-ed storage, so that in
X * the future we don't have to worry about which entries
X * are malloc-ed and which are static.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XEnvInit()
X{
X char **newEnviron;

X int i, length;
X

X if (environSize != 0) {
X return;
X }
X for (length = 0; environ[length] != NULL; length++) {
X /* Empty loop body. */
X }
X environSize = length+5;
X newEnviron = (char **) ckalloc((unsigned)
X (environSize * sizeof(char *)));
X for (i = 0; i < length; i++) {
X newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1));
X strcpy(newEnviron[i], environ[i]);
X }
X newEnviron[length] = NULL;
X environ = newEnviron;
X}
END_OF_FILE
if test 11191 -ne `wc -c <'tcl6.1/tclEnv.c'`; then
echo shar: \"'tcl6.1/tclEnv.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclEnv.c'
fi
if test -f 'tcl6.1/tests/info.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/info.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/info.test'\" $11222 characters$
sed "s/^X//" >'tcl6.1/tests/info.test' <<'END_OF_FILE'
X# Commands covered: info

X# $Header: /sprite/src/lib/tcl/tests/RCS/info.test,v 1.10 91/09/23 13:06:05 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest info-1.1 {info args option} {
X proc t1 {a bbb c} {return foo}
X info args t1
X} {a bbb c}
Xtest info-1.2 {info args option} {
X proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
X info a t1
X} {a bbb c args}
Xtest info-1.3 {info args option} {
X proc t1 "" {return foo}
X info args t1
X} {}
Xtest info-1.4 {info args option} {
X catch {rename t1 {}}
X list [catch {info args t1} msg] $msg
X} {1 {"t1" isn't a procedure}}
Xtest info-1.5 {info args option} {
X list [catch {info args set} msg] $msg
X} {1 {"set" isn't a procedure}}
X
Xtest info-2.1 {info body option} {
X proc t1 {} {body of t1}
X info body t1
X} {body of t1}
Xtest info-2.2 {info body option} {
X list [catch {info body set} msg] $msg
X} {1 {"set" isn't a procedure}}
Xtest info-2.3 {info body option} {
X list [catch {info args set 1} msg] $msg
X} {1 {wrong # args: should be "info args procname"}}
X
Xtest info-3.1 {info cmdcount option} {
X set x [info cmdcount]
X set y 12345
X set z [info cm]
X expr $z-$x
X} 3
Xtest info-3.2 {info body option} {
X list [catch {info cmdcount 1} msg] $msg
X} {1 {wrong # args: should be "info cmdcount"}}
X
Xtest info-4.1 {info commands option} {
X proc t1 {} {}
X proc t2 {} {}
X set x " [info commands] "
X list [string match {* t1 *} $x] [string match {* t2 *} $x] \
X [string match {* set *} $x] [string match {* list *} $x]

X} {1 1 1 1}

Xtest info-4.2 {info commands option} {
X proc t1 {} {}
X rename t1 {}
X set x [info co]
X string match {* t1 *} $x
X} 0
Xtest info-4.3 {info commands option} {
X proc _t1_ {} {}
X proc _t2_ {} {}
X info commands _t1_
X} _t1_
Xtest info-4.4 {info commands option} {
X proc _t1_ {} {}
X proc _t2_ {} {}
X lsort [info commands _t*]
X} {_t1_ _t2_}
Xcatch {rename _t1_ {}}
Xcatch {rename _t2_ {}}
Xtest info-4.5 {info commands option} {
X list [catch {info commands a b} msg] $msg
X} {1 {wrong # args: should be "info commands [pattern]"}}
X
Xtest info-5.1 {info default option} {
X proc t1 {a b {c d} {e "long default value"}} {}
X info default t1 a value
X} 0
Xtest info-5.2 {info default option} {
X proc t1 {a b {c d} {e "long default value"}} {}
X set value 12345
X info d t1 a value
X set value
X} {}
Xtest info-5.3 {info default option} {
X proc t1 {a b {c d} {e "long default value"}} {}
X info default t1 c value
X} 1
Xtest info-5.4 {info default option} {
X proc t1 {a b {c d} {e "long default value"}} {}
X set value 12345
X info default t1 c value
X set value
X} d
Xtest info-5.5 {info default option} {
X proc t1 {a b {c d} {e "long default value"}} {}
X set value 12345
X set x [info default t1 e value]
X list $x $value
X} {1 {long default value}}
Xtest info-5.6 {info default option} {
X list [catch {info default a b} msg] $msg
X} {1 {wrong # args: should be "info default procname arg varname"}}
Xtest info-5.7 {info default option} {
X list [catch {info default _nonexistent_ a b} msg] $msg
X} {1 {"_nonexistent_" isn't a procedure}}
Xtest info-5.8 {info default option} {
X proc t1 {a b} {}
X list [catch {info default t1 x value} msg] $msg
X} {1 {procedure "t1" doesn't have an argument "x"}}
Xtest info-5.9 {info default option} {
X catch {unset a}
X set a(0) 88
X proc t1 {a b} {}
X list [catch {info default t1 a a} msg] $msg
X} {1 {couldn't store default value in variable "a"}}
Xtest info-5.10 {info default option} {
X catch {unset a}
X set a(0) 88
X proc t1 {{a 18} b} {}
X list [catch {info default t1 a a} msg] $msg
X} {1 {couldn't store default value in variable "a"}}
Xcatch {unset a}
X
Xtest info-6.1 {info exists option} {
X set value foo
X info exists value
X} 1
Xcatch {unset _nonexistent_}
Xtest info-6.2 {info exists option} {
X info exists _nonexistent_
X} 0
Xtest info-6.3 {info exists option} {
X proc t1 {x} {return [info exists x]}
X t1 2
X} 1
Xtest info-6.4 {info exists option} {
X proc t1 {x} {
X global _nonexistent_
X return [info exists _nonexistent_]
X }
X t1 2
X} 0
Xtest info-6.5 {info exists option} {
X proc t1 {x} {
X set y 47
X return [info exists y]
X }
X t1 2
X} 1
Xtest info-6.6 {info exists option} {
X proc t1 {x} {return [info exists value]}
X t1 2
X} 0
Xtest info-6.7 {info exists option} {
X catch {unset x}
X set x(2) 44
X list [info exists x] [info exists x(1)] [info exists x(2)]
X} {1 0 1}
Xcatch {unset x}
Xtest info-6.8 {info exists option} {
X list [catch {info exists} msg] $msg
X} {1 {wrong # args: should be "info exists varName"}}
Xtest info-6.9 {info exists option} {
X list [catch {info exists 1 2} msg] $msg
X} {1 {wrong # args: should be "info exists varName"}}
X
Xtest info-7.1 {info globals option} {
X set x 1
X set y 2
X set value 23
X set a " [info globals] "
X list [string match {* x *} $a] [string match {* y *} $a] \
X [string match {* value *} $a] [string match {* _foobar_ *} $a]
X} {1 1 1 0}
Xtest info-7.2 {info globals option} {
X set _xxx1 1
X set _xxx2 2
X lsort [info g _xxx*]
X} {_xxx1 _xxx2}
Xtest info-7.3 {info globals option} {
X list [catch {info globals 1 2} msg] $msg
X} {1 {wrong # args: should be "info globals [pattern]"}}
X
Xtest info-8.1 {info level option} {
X info level
X} 0
Xtest info-8.2 {info level option} {
X proc t1 {a b} {
X set x [info le]

X set y [info level 1]

X list $x $y
X }
X t1 146 testString
X} {1 {t1 146 testString}}
Xtest info-8.3 {info level option} {
X proc t1 {a b} {
X t2 [expr $a*2] $b
X }
X proc t2 {x y} {
X list [info level] [info level 1] [info level 2] [info level -1] \
X [info level 0]
X }
X t1 146 {a {b c} {{{c}}}}
X} {2 {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}} {t1 146 {a {b c} {{{c}}}}} {t2 292 {a {b c} {{{c}}}}}}
Xtest info-8.4 {info level option} {
X proc t1 {} {

X set x [info level]
X set y [info level 1]

X list $x $y
X }
X t1
X} {1 t1}
Xtest info-8.5 {info level option} {
X list [catch {info level 1 2} msg] $msg
X} {1 {wrong # args: should be "info level [number]"}}
Xtest info-8.6 {info level option} {
X list [catch {info level 123a} msg] $msg
X} {1 {expected integer but got "123a"}}
Xtest info-8.7 {info level option} {
X list [catch {info level 0} msg] $msg
X} {1 {bad level "0"}}
Xtest info-8.8 {info level option} {
X proc t1 {} {info level -1}
X list [catch {t1} msg] $msg
X} {1 {bad level "-1"}}
Xtest info-8.9 {info level option} {
X proc t1 {x} {info level $x}
X list [catch {t1 -3} msg] $msg
X} {1 {bad level "-3"}}
X
Xtest info-9.1 {info library option} {
X list [catch {info library x} msg] $msg
X} {1 {wrong # args: should be "info library"}}
X
X# The following check can only be done at Berkeley, where the exact
X# location of the library is known.
X
Xif {[glob ~] == "/users/ouster"} {
X test info-9.2 {info library option} {
X info li
X } /sprite/lib/tcl
X}
X
Xtest info-10.1 {info locals option} {
X set a 22
X proc t1 {x y} {
X set b 13
X set c testing
X global a
X return [info locals]
X }
X lsort [t1 23 24]
X} {b c x y}
Xtest info-10.2 {info locals option} {
X proc t1 {x y} {
X set xx1 2
X set xx2 3
X set y 4
X return [info lo x*]
X }
X lsort [t1 2 3]
X} {x xx1 xx2}
Xtest info-10.3 {info locals option} {
X list [catch {info locals 1 2} msg] $msg
X} {1 {wrong # args: should be "info locals [pattern]"}}
Xtest info-10.4 {info locals option} {
X info locals
X} {}
Xtest info-10.5 {info locals option} {
X proc t1 {} {return [info locals]}
X t1
X} {}
X
Xtest info-11.1 {info procs option} {
X proc t1 {} {}
X proc t2 {} {}
X set x " [info procs] "
X list [string match {* t1 *} $x] [string match {* t2 *} $x] \
X [string match {* _undefined_ *} $x]
X} {1 1 0}
Xtest info-11.2 {info procs option} {
X proc _tt1 {} {}
X proc _tt2 {} {}
X lsort [info p _tt*]
X} {_tt1 _tt2}
Xcatch {rename _tt1 {}}
Xcatch {rename _tt2 {}}
Xtest info-11.3 {info procs option} {
X list [catch {info procs 2 3} msg] $msg
X} {1 {wrong # args: should be "info procs [pattern]"}}
X
Xtest info-12.1 {info script option} {
X list [catch {info script x} msg] $msg
X} {1 {wrong # args: should be "info script"}}
Xtest info-12.2 {info script option} {
X file tail [info s]
X} info.test
Xcatch {exec rm -f gorp.info}
Xexec cat > gorp.info << "info script\n"
Xtest info-12.3 {info script option} {
X list [source gorp.info] [file tail [info script]]
X} {gorp.info info.test}
Xtest info-12.4 {resetting "info script" after errors} {
X catch {source ~_nobody_/foo}
X file tail [info script]
X} {info.test}
Xtest info-12.5 {resetting "info script" after errors} {
X catch {source _nonexistent_}
X file tail [info script]
X} {info.test}
Xexec rm -f gorp.info
X
Xtest info-13.1 {info tclversion option} {
X set x [info tclversion]
X scan $x "%d.%d%c" a b c
X} 2
Xtest info-13.2 {info tclversion option} {
X list [catch {info t 2} msg] $msg
X} {1 {wrong # args: should be "info tclversion"}}
X
Xtest info-14.1 {info vars option} {
X set a 1
X set b 2
X proc t1 {x y} {
X global a b
X set c 33
X return [info vars]
X }
X lsort [t1 18 19]
X} {a b c x y}
Xtest info-14.2 {info vars option} {
X set xxx1 1
X set xxx2 2
X proc t1 {xxa y} {
X global xxx1 xxx2
X set c 33
X return [info vars x*]
X }
X lsort [t1 18 19]
X} {xxa xxx1 xxx2}
Xtest info-14.3 {info vars option} {
X lsort [info vars]
X} [lsort [info globals]]
Xtest info-14.4 {info vars option} {
X list [catch {info vars a b} msg] $msg
X} {1 {wrong # args: should be "info vars [pattern]"}}
X
Xtest info-15.1 {miscellaneous error conditions} {
X list [catch {info} msg] $msg
X} {1 {wrong # args: should be "info option ?arg arg ...?"}}
Xtest info-15.2 {miscellaneous error conditions} {
X list [catch {info gorp} msg] $msg
X} {1 {bad option "gorp": should be args, body, commands, cmdcount, default, \
Xexists, globals, level, library, locals, procs, script, tclversion, or vars}}
Xtest info-15.3 {miscellaneous error conditions} {
X list [catch {info c} msg] $msg
X} {1 {bad option "c": should be args, body, commands, cmdcount, default, \
Xexists, globals, level, library, locals, procs, script, tclversion, or vars}}
Xtest info-15.4 {miscellaneous error conditions} {
X list [catch {info l} msg] $msg
X} {1 {bad option "l": should be args, body, commands, cmdcount, default, \
Xexists, globals, level, library, locals, procs, script, tclversion, or vars}}
END_OF_FILE
if test 11222 -ne `wc -c <'tcl6.1/tests/info.test'`; then
echo shar: \"'tcl6.1/tests/info.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/info.test'
fi
echo shar: End of archive 9 $of 33$.
cp /dev/null ark9isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:29:31 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 78
Archive-name: tcl/part10
Environment: UNIX

# "End of archive 10 (of 33)."
# Contents: tcl6.1/compat/strerror.c tcl6.1/doc/Hash.man
# tcl6.1/tests/format.test tcl6.1/tests/parse.test
# Wrapped by karl@one on Tue Nov 12 19:44:19 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/compat/strerror.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/compat/strerror.c'\"
else
echo shar: Extracting \"'tcl6.1/compat/strerror.c'\" $11480 characters$
sed "s/^X//" >'tcl6.1/compat/strerror.c' <<'END_OF_FILE'
X/*
X * strerror.c --
X *
X * Source code for the "strerror" library routine.

X *
X * Copyright 1988-1991 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 appears 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/compat/RCS/strerror.c,v 1.1 91/09/19 16:22:10 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include <tclInt.h>
X#include <tclUnix.h>

X
X/*
X *----------------------------------------------------------------------
X *

X * strerror --
X *
X * Map an integer error number into a printable string.

X *
X * Results:

X * The return value is a pointer to a string describing
X * error. The first character of string isn't capitalized.

X *
X * Side effects:

X * Each call to this procedure may overwrite the value returned
X * by the previous call.

X *
X *----------------------------------------------------------------------
X */
X
Xchar *

Xstrerror(error)
X int error; /* Integer identifying error (must be
X * one of the officially-defined Sprite
X * errors, as defined in errno.h). */
X{
X static char msg[50];
X
X#if TCL_SYS_ERRLIST
X if ((error <= sys_nerr) && (error > 0)) {
X return sys_errlist[error];
X }
X#else
X switch (error) {
X#ifdef E2BIG
X case E2BIG: return "argument list too long";
X#endif
X#ifdef EACCES
X case EACCES: return "permission denied";
X#endif
X#ifdef EADDRINUSE
X case EADDRINUSE: return "address already in use";
X#endif
X#ifdef EADDRNOTAVAIL
X case EADDRNOTAVAIL: return "can't assign requested address";
X#endif
X#ifdef EADV
X case EADV: return "advertise error";
X#endif
X#ifdef EAFNOSUPPORT
X case EAFNOSUPPORT: return "address family not supported by protocol family";
X#endif
X#ifdef EAGAIN
X case EAGAIN: return "no more processes";
X#endif
X#ifdef EALIGN
X case EALIGN: return "EALIGN";
X#endif
X#ifdef EALREADY
X case EALREADY: return "operation already in progress";
X#endif
X#ifdef EBADE
X case EBADE: return "bad exchange descriptor";
X#endif
X#ifdef EBADF
X case EBADF: return "bad file number";
X#endif
X#ifdef EBADFD
X case EBADFD: return "file descriptor in bad state";
X#endif
X#ifdef EBADMSG
X case EBADMSG: return "not a data message";
X#endif
X#ifdef EBADR
X case EBADR: return "bad request descriptor";
X#endif
X#ifdef EBADRPC
X case EBADRPC: return "RPC structure is bad";
X#endif
X#ifdef EBADRQC
X case EBADRQC: return "bad request code";
X#endif
X#ifdef EBADSLT
X case EBADSLT: return "invalid slot";
X#endif
X#ifdef EBFONT
X case EBFONT: return "bad font file format";
X#endif
X#ifdef EBUSY
X case EBUSY: return "mount device busy";
X#endif
X#ifdef ECHILD
X case ECHILD: return "no children";
X#endif
X#ifdef ECHRNG
X case ECHRNG: return "channel number out of range";
X#endif
X#ifdef ECOMM
X case ECOMM: return "communication error on send";
X#endif
X#ifdef ECONNABORTED
X case ECONNABORTED: return "software caused connection abort";
X#endif
X#ifdef ECONNREFUSED
X case ECONNREFUSED: return "connection refused";
X#endif
X#ifdef ECONNRESET
X case ECONNRESET: return "connection reset by peer";
X#endif
X#ifdef EDEADLK
X#ifndef EWOULDBLOCK
X case EDEADLK: return "resource deadlock avoided";
X#else
X#if EWOULDBLOCK != EDEADLK
X case EDEADLK: return "resource deadlock avoided";
X#endif /* EWOULDBLOCK != EDEADLK */
X#endif /* EWOULDBLOCK */
X#endif /* EDEADLK */
X#ifdef EDEADLOCK
X case EDEADLOCK: return "resource deadlock avoided";
X#endif
X#ifdef EDESTADDRREQ
X case EDESTADDRREQ: return "destination address required";
X#endif
X#ifdef EDIRTY
X case EDIRTY: return "mounting a dirty fs w/o force";
X#endif
X#ifdef EDOM
X case EDOM: return "math argument out of range";
X#endif
X#ifdef EDOTDOT
X case EDOTDOT: return "cross mount point";
X#endif
X#ifdef EDQUOT
X case EDQUOT: return "disk quota exceeded";
X#endif
X#ifdef EDUPPKG
X case EDUPPKG: return "duplicate package name";
X#endif
X#ifdef EEXIST
X case EEXIST: return "file already exists";
X#endif
X#ifdef EFAULT
X case EFAULT: return "bad address in system call argument";
X#endif
X#ifdef EFBIG
X case EFBIG: return "file too large";
X#endif
X#ifdef EHOSTDOWN
X case EHOSTDOWN: return "host is down";
X#endif
X#ifdef EHOSTUNREACH
X case EHOSTUNREACH: return "host is unreachable";
X#endif
X#ifdef EIDRM
X case EIDRM: return "identifier removed";
X#endif
X#ifdef EINIT
X case EINIT: return "initialization error";
X#endif
X#ifdef EINPROGRESS
X case EINPROGRESS: return "operation now in progress";
X#endif
X#ifdef EINTR
X case EINTR: return "interrupted system call";
X#endif
X#ifdef EINVAL
X case EINVAL: return "invalid argument";
X#endif
X#ifdef EIO
X case EIO: return "I/O error";
X#endif
X#ifdef EISCONN
X case EISCONN: return "socket is already connected";
X#endif
X#ifdef EISDIR
X case EISDIR: return "illegal operation on a directory";
X#endif
X#ifdef EISNAME
X case EISNAM: return "is a name file";
X#endif
X#ifdef ELBIN
X case ELBIN: return "ELBIN";
X#endif
X#ifdef EL2HLT
X case EL2HLT: return "level 2 halted";
X#endif
X#ifdef EL2NSYNC
X case EL2NSYNC: return "level 2 not synchronized";
X#endif
X#ifdef EL3HLT
X case EL3HLT: return "level 3 halted";
X#endif
X#ifdef EL3RST
X case EL3RST: return "level 3 reset";
X#endif
X#ifdef ELIBACC
X case ELIBACC: return "can not access a needed shared library";
X#endif
X#ifdef ELIBBAD
X case ELIBBAD: return "accessing a corrupted shared library";
X#endif
X#ifdef ELIBEXEC
X case ELIBEXEC: return "can not exec a shared library directly";
X#endif
X#ifdef ELIBMAX
X case ELIBMAX: return
X "attempting to link in more shared libraries than system limit";
X#endif
X#ifdef ELIBSCN
X case ELIBSCN: return ".lib section in a.out corrupted";
X#endif
X#ifdef ELNRNG
X case ELNRNG: return "link number out of range";
X#endif
X#ifdef ELOOP
X case ELOOP: return "too many levels of symbolic links";
X#endif
X#ifdef EMFILE
X case EMFILE: return "too many open files";
X#endif
X#ifdef EMLINK
X case EMLINK: return "too many links";
X#endif
X#ifdef EMSGSIZE
X case EMSGSIZE: return "message too long";
X#endif
X#ifdef EMULTIHOP
X case EMULTIHOP: return "multihop attempted";
X#endif
X#ifdef ENAMETOOLONG
X case ENAMETOOLONG: return "file name too long";
X#endif
X#ifdef ENAVAIL
X case ENAVAIL: return "not available";
X#endif
X#ifdef ENET
X case ENET: return "ENET";
X#endif
X#ifdef ENETDOWN
X case ENETDOWN: return "network is down";
X#endif
X#ifdef ENETRESET
X case ENETRESET: return "network dropped connection on reset";
X#endif
X#ifdef ENETUNREACH
X case ENETUNREACH: return "network is unreachable";
X#endif
X#ifdef ENFILE
X case ENFILE: return "file table overflow";
X#endif
X#ifdef ENOANO
X case ENOANO: return "anode table overflow";
X#endif
X#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))
X case ENOBUFS: return "no buffer space available";
X#endif
X#ifdef ENOCSI
X case ENOCSI: return "no CSI structure available";
X#endif
X#ifdef ENODATA
X case ENODATA: return "no data available";
X#endif
X#ifdef ENODEV
X case ENODEV: return "no such device";
X#endif
X#ifdef ENOENT
X case ENOENT: return "no such file or directory";
X#endif
X#ifdef ENOEXEC
X case ENOEXEC: return "exec format error";
X#endif
X#ifdef ENOLCK
X case ENOLCK: return "no locks available";
X#endif
X#ifdef ENOLINK
X case ENOLINK: return "link has be severed";
X#endif
X#ifdef ENOMEM
X case ENOMEM: return "not enough memory";
X#endif
X#ifdef ENOMSG
X case ENOMSG: return "no message of desired type";
X#endif
X#ifdef ENONET
X case ENONET: return "machine is not on the network";
X#endif
X#ifdef ENOPKG
X case ENOPKG: return "package not installed";
X#endif
X#ifdef ENOPROTOOPT
X case ENOPROTOOPT: return "bad proocol option";
X#endif
X#ifdef ENOSPC
X case ENOSPC: return "no space left on device";
X#endif
X#ifdef ENOSR
X case ENOSR: return "out of stream resources";
X#endif
X#ifdef ENOSTR
X case ENOSTR: return "not a stream device";
X#endif
X#ifdef ENOSYM
X case ENOSYM: return "unresolved symbol name";
X#endif
X#ifdef ENOSYS
X case ENOSYS: return "function not implemented";
X#endif
X#ifdef ENOTBLK
X case ENOTBLK: return "block device required";
X#endif
X#ifdef ENOTCONN
X case ENOTCONN: return "socket is not connected";
X#endif
X#ifdef ENOTDIR
X case ENOTDIR: return "not a directory";
X#endif
X#ifdef ENOTEMPTY
X case ENOTEMPTY: return "directory not empty";
X#endif
X#ifdef ENOTNAM
X case ENOTNAM: return "not a name file";
X#endif
X#ifdef ENOTSOCK
X case ENOTSOCK: return "socket operation on non-socket";
X#endif
X#ifdef ENOTTY
X case ENOTTY: return "inappropriate device for ioctl";
X#endif
X#ifdef ENOTUNIQ
X case ENOTUNIQ: return "name not unique on network";
X#endif
X#ifdef ENXIO
X case ENXIO: return "no such device or address";
X#endif
X#ifdef EOPNOTSUPP
X case EOPNOTSUPP: return "operation not supported on socket";
X#endif
X#ifdef EPERM
X case EPERM: return "not owner";
X#endif
X#ifdef EPFNOSUPPORT
X case EPFNOSUPPORT: return "protocol family not supported";
X#endif
X#ifdef EPIPE
X case EPIPE: return "broken pipe";
X#endif
X#ifdef EPROCLIM
X case EPROCLIM: return "too many processes";
X#endif
X#ifdef EPROCUNAVAIL
X case EPROCUNAVAIL: return "bad procedure for program";
X#endif
X#ifdef EPROGMISMATCH
X case EPROGMISMATCH: return "program version wrong";
X#endif
X#ifdef EPROGUNAVAIL
X case EPROGUNAVAIL: return "RPC program not available";
X#endif
X#ifdef EPROTO
X case EPROTO: return "protocol error";
X#endif
X#ifdef EPROTONOSUPPORT
X case EPROTONOSUPPORT: return "protocol not suppored";
X#endif
X#ifdef EPROTOTYPE
X case EPROTOTYPE: return "protocol wrong type for socket";
X#endif
X#ifdef ERANGE
X case ERANGE: return "math result unrepresentable";
X#endif
X#ifdef EREFUSED
X case EREFUSED: return "EREFUSED";
X#endif
X#ifdef EREMCHG
X case EREMCHG: return "remote address changed";
X#endif
X#ifdef EREMDEV
X case EREMDEV: return "remote device";
X#endif
X#ifdef EREMOTE
X case EREMOTE: return "pathname hit remote file system";
X#endif
X#ifdef EREMOTEIO
X case EREMOTEIO: return "remote i/o error";
X#endif
X#ifdef EREMOTERELEASE
X case EREMOTERELEASE: return "EREMOTERELEASE";
X#endif
X#ifdef EROFS
X case EROFS: return "read-only file system";
X#endif
X#ifdef ERPCMISMATCH
X case ERPCMISMATCH: return "RPC version is wrong";
X#endif
X#ifdef ERREMOTE
X case ERREMOTE: return "object is remote";
X#endif
X#ifdef ESHUTDOWN
X case ESHUTDOWN: return "can't send afer socket shutdown";
X#endif
X#ifdef ESOCKTNOSUPPORT
X case ESOCKTNOSUPPORT: return "socket type not supported";
X#endif
X#ifdef ESPIPE
X case ESPIPE: return "invalid seek";
X#endif
X#ifdef ESRCH
X case ESRCH: return "no such process";
X#endif
X#ifdef ESRMNT
X case ESRMNT: return "srmount error";
X#endif
X#ifdef ESTALE
X case ESTALE: return "stale remote file handle";
X#endif
X#ifdef ESUCCESS
X case ESUCCESS: return "Error 0";
X#endif
X#ifdef ETIME
X case ETIME: return "timer expired";
X#endif
X#ifdef ETIMEDOUT
X case ETIMEDOUT: return "connection timed out";
X#endif
X#ifdef ETOOMANYREFS
X case ETOOMANYREFS: return "too many references: can't splice";
X#endif
X#ifdef ETXTBSY
X case ETXTBSY: return "text file or pseudo-device busy";
X#endif
X#ifdef EUCLEAN
X case EUCLEAN: return "structure needs cleaning";
X#endif
X#ifdef EUNATCH
X case EUNATCH: return "protocol driver not attached";
X#endif
X#ifdef EUSERS
X case EUSERS: return "too many users";
X#endif
X#ifdef EVERSION
X case EVERSION: return "version mismatch";
X#endif
X#ifdef EWOULDBLOCK
X case EWOULDBLOCK: return "operation would block";
X#endif
X#ifdef EXDEV
X case EXDEV: return "cross-domain link";
X#endif
X#ifdef EXFULL
X case EXFULL: return "message tables full";
X#endif
X }
X#endif /* ! TCL_SYS_ERRLIST */
X sprintf(msg, "unknown error (%d)", error);
X return msg;
X}
END_OF_FILE
if test 11480 -ne `wc -c <'tcl6.1/compat/strerror.c'`; then
echo shar: \"'tcl6.1/compat/strerror.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/compat/strerror.c'
fi
if test -f 'tcl6.1/doc/Hash.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Hash.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/Hash.man'\" $12084 characters$
sed "s/^X//" >'tcl6.1/doc/Hash.man' <<'END_OF_FILE'
X'\" Copyright 1989 Regents of the University of California

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Hash.man,v 1.3 91/08/27 10:41:42 ouster Exp $ SPRITE (Berkeley)
X'\"

X.HS Tcl_Hash tcl
X.BS
X.SH NAME
X.na
XTcl_InitHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, \
XTcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, \
XTcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, \
XTcl_HashStats \- procedures to manage hash tables
X.SH SYNOPSIS
X.nf
X\fB#include <tclHash.h>\fR
X.sp
X\fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR)
X.sp
X\fBTcl_DeleteHashTable\fR(\fItablePtr\fR)
X.sp
XTcl_HashEntry *
X\fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR)
X.sp
X\fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR)
X.sp
XTcl_HashEntry *
X\fBTcl_FindHashEntry\fR(\fItablePtr, key\fR)
X.sp
XClientData
X\fBTcl_GetHashValue\fR(\fIentryPtr\fR)
X.sp
X\fBTcl_SetHashValue\fR(\fIentryPtr, value\fR)
X.sp
Xchar *
X\fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR)
X.sp
XTcl_HashEntry *
X\fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR)
X.sp
XTcl_HashEntry *
X\fBTcl_NextHashEntry\fR(\fIsearchPtr\fR)
X.sp
Xchar *
X\fBTcl_HashStats\fR(\fItablePtr\fR)
X.SH ARGUMENTS
X.AS Tcl_HashSearch *searchPtr
X.AP Tcl_HashTable *tablePtr in
XAddress of hash table structure (for all procedures but
X\fBTcl_InitHashTable\fR, this must have been initialized by
Xprevious call to \fBTcl_InitHashTable\fR).
X.AP int keyType in
XKind of keys to use for new hash table. Must be either
XTCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an integer value
Xgreater than 1.
X.AP char *key in
XKey to use for probe into table. Exact form depends on
X\fIkeyType\fR used to create table.
X.AP int *newPtr out
XThe word at \fI*newPtr\fR is set to 1 if a new entry was created
Xand 0 if there was already an entry for \fIkey\fR.
X.AP Tcl_HashEntry *entryPtr in
XPointer to hash table entry.
X.AP ClientData value in
XNew value to assign to hash table entry. Need not have type
XClientData, but must fit in same space as ClientData.
X.AP Tcl_HashSearch *searchPtr in
XPointer to record to use to keep track of progress in enumerating
Xall the entries in a hash table.

X.BE
X
X.SH DESCRIPTION
X.PP

XA hash table consists of zero or more entries, each consisting of
Xa key and a value.
XGiven the key for an entry, the hashing routines can very quickly
Xlocate the entry, and hence its value.
XThere may be at most one entry in a hash table with a
Xparticular key, but many entries may have the same value.
XKeys can take one of three forms: strings,
Xone-word values, or integer arrays.
XAll of the keys in a given table have the same form, which is
Xspecified when the table is initialized.
X.PP
XThe value of a hash table entry can be anything that fits in
Xthe same space as a ``char *'' pointer.
XValues for hash table entries are managed entirely by clients,
Xnot by the hash module itself.
XTypically each entry's value is a pointer to a data structure
Xmanaged by client code.
X.PP
XHash tables grow gracefully as the number of entries increases,
Xso that there are always less than three entries per hash bucket,
Xon average.
XThis allows for fast lookups regardless of the number of entries
Xin a table.
X.PP
X\fBTcl_InitHashTable\fR initializes a structure that describes
Xa new hash table.
XThe space for the structure is provided by the caller, not by
Xthe hash module.
XThe value of \fIkeyType\fR indicates what kinds of keys will
Xbe used for all entries in the table. \fIKeyType\fR must have
Xone of the following values:
X.IP \fBTCL_STRING_KEYS\fR 25
XKeys are null-terminated ASCII strings.
XThey are passed to hashing routines using the address of the
Xfirst character of the string.
X.IP \fBTCL_ONE_WORD_KEYS\fR 25
XKeys are single-word values; they are passed to hashing routines
Xand stored in hash table entries as ``char *'' values.
XThe pointer value is the key; it need not (and usually doesn't)
Xactually point to a string.
X.IP \fIother\fR 25
XIf \fIkeyType\fR is not TCL_STRING_KEYS or TCL_ONE_WORD_KEYS,
Xthen it must be an integer value greater than 1.
XIn this case the keys will be arrays of ``int'' values, where
X\fIkeyType\fR gives the number of ints in each key.
XThis allows structures to be used as keys.
XAll keys must have the same size.
XArray keys are passed into hashing functions using the address
Xof the first int in the array.
X.PP
X\fBTcl_DeleteHashTable\fR deletes all of the entries in a hash
Xtable and frees up the memory associated with the table's
Xbucket array and entries.
XIt does not free the actual table structure (pointed to
Xby \fItablePtr\fR), since that memory is assumed to be managed
Xby the client.
X\fBTcl_DeleteHashTable\fR also does not free or otherwise
Xmanipulate the values of the hash table entries.
XIf the entry values point to dynamically-allocated memory, then
Xit is the client's responsibility to free these structures
Xbefore deleting the table.
X.PP
X\fBTcl_CreateHashEntry\fR locates the entry corresponding to a
Xparticular key, creating a new entry in the table if there
Xwasn't already one with the given key.
XIf an entry already existed with the given key then \fI*newPtr\fR
Xis set to zero.
XIf a new entry was created, then \fI*newPtr\fR is set to a non-zero
Xvalue and the value of the new entry will be set to zero.
XThe return value from \fBTcl_CreateHashEntry\fR is a pointer to
Xthe entry, which may be used to retrieve and modify the entry's
Xvalue or to delete the entry from the table.
X.PP
X\fBTcl_DeleteHashEntry\fR will remove an existing entry from a
Xtable.
XThe memory associated with the entry itself will be freed, but
Xthe client is responsible for any cleanup associated with the
Xentry's value, such as freeing a structure that it points to.
X.PP
X\fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR
Xexcept that it doesn't create a new entry if the key doesn't exist;
Xinstead, it returns NULL as result.
X.PP
X\fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to
Xread and write an entry's value, respectively.
XValues are stored and retrieved as type ``ClientData'', which is
Xlarge enough to hold a pointer value. On almost all machines this is
Xlarge enough to hold an integer value too.
X.PP
X\fBTcl_GetHashKey\fR returns the key for a given hash table entry,
Xeither as a pointer to a string, a one-word (``char *'') key, or
Xas a pointer to the first word of an array of integers, depending
Xon the \fIkeyType\fR used to create a hash table.
XIn all cases \fBTcl_GetHashKey\fR returns a result with type
X``char *''.
XWhen the key is a string or array, the result of \fBTcl_GetHashKey\fR
Xpoints to information in the table entry; this information will
Xremain valid until the entry is deleted or its table is deleted.
X.PP
X\fBTcl_FirstHashEntry\fR and \fBTcl_NextHashEntry\fR may be used
Xto scan all of the entries in a hash table.
XA structure of type ``Tcl_HashSearch'', provided by the client,
Xis used to keep track of progress through the table.
X\fBTcl_FirstHashEntry\fR initializes the search record and
Xreturns the first entry in the table (or NULL if the table is
Xempty).
XEach susequent call to \fBTcl_NextHashEntry\fR returns the
Xnext entry in the table or
XNULL if the end of the table has been reached.
XA call to \fBTcl_FirstHashEntry\fR followed by calls to
X\fBTcl_NextHashEntry\fR will return each of the entries in
Xthe table exactly once, in an arbitrary order.
XIt is unadvisable to modify the structure of the table, e.g.
Xby creating or deleting entries, while the search is in
Xprogress.
X.PP
X\fBTcl_HashStats\fR returns a dynamically-allocated string with
Xoverall information about a hash table, such as the number of
Xentries it contains, the number of buckets in its hash array,
Xand the utilization of the buckets.
XIt is the caller's responsibility to free the result string
Xby passing it to \fBfree\fR.
X.PP
XThe header file \fBtclHash.h\fR defines the actual data structures
Xused to implement hash tables.
XThis is necessary so that clients can allocate Tcl_HashTable
Xstructures and so that macros can be used to read and write
Xthe values of entries.
XHowever, users of the hashing routines should never refer directly
Xto any of the fields of any of the hash-related data structures;
Xuse the procedures and macros defined here.
X
X.SH KEYWORDS
Xhash table, key, lookup, search, value
END_OF_FILE
if test 12084 -ne `wc -c <'tcl6.1/doc/Hash.man'`; then
echo shar: \"'tcl6.1/doc/Hash.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Hash.man'
fi
if test -f 'tcl6.1/tests/format.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/format.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/format.test'\" $11548 characters$
sed "s/^X//" >'tcl6.1/tests/format.test' <<'END_OF_FILE'
X# Commands covered: format

X# $Header: /sprite/src/lib/tcl/tests/RCS/format.test,v 1.6 91/09/17 11:32:01 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# The following code is needed because some versions of SCO Unix have
X# a round-off error in sprintf which would cause some of the tests to
X# fail. Someday I hope this code shouldn't be necessary (code added
X# 9/9/91).
X
Xset roundOffBug 0
Xif {"[format %7.1e 68.514]" == "6.8e+01"} {
X puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n"
X set roundOffBug 1
X}
X
Xtest format-1.1 {integer formatting} {
X format "%*d %d %d %d" 6 34 16923 -12 -1
X} { 34 16923 -12 -1}
Xtest format-1.2 {integer formatting} {
X format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 0 0
X} { 6 34 16923 -12 -1 0 0}
Xtest format-1.3 {integer formatting} {
X format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
X} { 6 34 16923 4294967284 -1 0}
Xtest format-1.4 {integer formatting} {
X format "%-4d %-4d %-4d %-4ld" 6 34 16923 -12 -1
X} {6 34 16923 -12 }
Xtest format-1.5 {integer formatting} {
X format "%04d %04d %04d %04d" 6 34 16923 -12 -1
X} {0006 0034 16923 -012}
Xtest format-1.6 {integer formatting} {
X format "%00*d" 6 34
X} {000034}
Xtest format-1.7 {integer formatting} {
X format "%4x %4x %4x %4x" 6 34 16923 -12 -1
X} { 6 22 421b fffffff4}
Xtest format-1.8 {integer formatting} {
X format "%#x %#X %#X %#x" 6 34 16923 -12 -1
X} {0x6 0X22 0X421B 0xfffffff4}
Xtest format-1.9 {integer formatting} {
X format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1
X} { 0x6 0x22 0x421b 0xfffffff4}
Xtest format-1.10 {integer formatting} {
X format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1
X} {0x6 0x22 0x421b 0xfffffff4 }
Xtest format-1.11 {integer formatting} {
X format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1
X} {06 042 041033 037777777764 }
X
Xtest format-2.1 {string formatting} {
X format "%s %s %c %s" abcd {This is a very long test string.} 120 x
X} {abcd This is a very long test string. x x}
Xtest format-2.2 {string formatting} {
X format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
X} { abcd This is a very long test string. x x}
Xtest format-2.3 {string formatting} {
X format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x
X} {abcd This is a x x}
Xtest format-2.4 {string formatting} {
X format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x
X} {abcd This is a very long test string. % x x}
X
Xtest format-3.1 {e and f formats} {
X format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053
X} {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
Xtest format-3.2 {e and f formats} {
X format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
X} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
Xif {!$roundOffBug} {
X test format-3.3 {e and f formats} {
X format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
X } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
X test format-3.4 {e and f formats} {
X format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
X } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
X test format-3.5 {e and f formats} {
X format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
X } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
X test format-3.6 {e and f formats} {
X format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
X } {34200000000000.000000 68.514000 -0.125000 -16000.000000}
X}
Xtest format-3.7 {e and f formats} {
X format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
X} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
Xtest format-3.8 {e and f formats} {
X format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996
X} {-1.0000e+01 -9.99996e+00 9.999960e+00}
Xtest format-3.9 {e and f formats} {
X format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
X} {-10.0000 -9.99996 9.999960}
Xtest format-3.10 {e and f formats} {
X format "%20f %-20f %020f" -9.99996 -9.99996 9.99996
X} { -9.999960 -9.999960 0000000000009.999960}
Xtest format-3.11 {e and f formats} {
X format "%-020f %020f" -9.99996 -9.99996 9.99996
X} {-9.999960 -000000000009.999960}
Xtest format-3.12 {e and f formats} {
X format "%.0e %#.0e" -9.99996 -9.99996 9.99996
X} {-1e+01 -1.e+01}
Xtest format-3.13 {e and f formats} {
X format "%.0f %#.0f" -9.99996 -9.99996 9.99996
X} {-10 -10.}
Xtest format-3.14 {e and f formats} {
X format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996
X} {-10.0000 -9.99996 9.999960}
Xtest format-3.15 {e and f formats} {
X format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001

X} { 1 1 1 1}

Xtest format-3.16 {e and f formats} {
X format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
X} {0.0 0.1 0.0 0.0}
X
Xtest format-4.1 {g-format} {
X format "%.3g" 12341.0
X} {1.23e+04}
Xtest format-4.2 {g-format} {
X format "%.3G" 1234.12345
X} {1.23E+03}
Xtest format-4.3 {g-format} {
X format "%.3g" 123.412345
X} {123}
Xtest format-4.4 {g-format} {
X format "%.3g" 12.3412345
X} {12.3}
Xtest format-4.5 {g-format} {
X format "%.3g" 1.23412345
X} {1.23}
Xtest format-4.6 {g-format} {
X format "%.3g" 1.23412345
X} {1.23}
Xtest format-4.7 {g-format} {
X format "%.3g" .123412345
X} {0.123}
Xtest format-4.8 {g-format} {
X format "%.3g" .012341
X} {0.0123}
Xtest format-4.9 {g-format} {
X format "%.3g" .0012341
X} {0.00123}
Xtest format-4.10 {g-format} {
X format "%.3g" .00012341
X} {0.000123}
Xtest format-4.11 {g-format} {
X format "%.3g" .00001234
X} {1.23e-05}
Xtest format-4.12 {g-format} {
X format "%.4g" 9999.6
X} {1e+04}
Xtest format-4.13 {g-format} {
X format "%.4g" 999.96
X} {1000}
Xtest format-4.14 {g-format} {
X format "%.3g" 1.0
X} {1}
Xtest format-4.15 {g-format} {
X format "%.3g" .1
X} {0.1}
Xtest format-4.16 {g-format} {
X format "%.3g" .01
X} {0.01}
Xtest format-4.17 {g-format} {
X format "%.3g" .001
X} {0.001}
Xtest format-4.19 {g-format} {
X format "%.3g" .00001
X} {1e-05}
Xtest format-4.20 {g-format} {
X format "%#.3g" 1234.0
X} {1.23e+03}
Xtest format-4.21 {g-format} {
X format "%#.3G" 9999.5
X} {1.00E+04}
X
Xtest format-5.1 {floating-point zeroes} {
X format "%e %f %g" 0.0 0.0 0.0 0.0
X} {0.000000e+00 0.000000 0}
Xtest format-5.2 {floating-point zeroes} {
X format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
X} {0.0000e+00 0.0000 0}
Xtest format-5.3 {floating-point zeroes} {
X format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
X} {0.0000e+00 0.0000 0.000}
Xtest format-5.4 {floating-point zeroes} {
X format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
X} {0e+00 0 0}
Xtest format-5.5 {floating-point zeroes} {
X format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
X} {0.e+00 0. 0.}
Xtest format-5.6 {floating-point zeroes} {
X format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0
X} { 0 0 0 0}
Xtest format-5.7 {floating-point zeroes} {
X format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001

X} { 1 1 1 1}

Xtest format-5.8 {floating-point zeroes} {
X format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001
X} {0.0 0.1 0.0 0.0}
X
Xtest format-6.1 {various syntax features} {
X format "%*.*f" 12 3 12.345678901
X} { 12.346}
Xtest format-6.2 {various syntax features} {
X format "%0*.*f" 12 3 12.345678901
X} {00000012.346}
X
Xtest format-7.1 {error conditions} {
X catch format
X} 1
Xtest format-7.2 {error conditions} {
X catch format msg
X set msg
X} {wrong # args: should be "format formatString ?arg arg ...?"}
Xtest format-7.3 {error conditions} {
X catch {format %*d}
X} 1
Xtest format-7.4 {error conditions} {
X catch {format %*d} msg
X set msg
X} {not enough arguments for all format specifiers}
Xtest format-7.5 {error conditions} {
X catch {format %*.*f 12}
X} 1
Xtest format-7.6 {error conditions} {
X catch {format %*.*f 12} msg
X set msg
X} {not enough arguments for all format specifiers}
Xtest format-7.7 {error conditions} {
X catch {format %*.*f 12 3}
X} 1
Xtest format-7.8 {error conditions} {
X catch {format %*.*f 12 3} msg
X set msg
X} {not enough arguments for all format specifiers}
Xtest format-7.9 {error conditions} {
X list [catch {format %*d x 3} msg] $msg
X} {1 {expected integer but got "x"}}
Xtest format-7.10 {error conditions} {
X list [catch {format %*.*f 2 xyz 3} msg] $msg

X} {1 {expected integer but got "xyz"}}

Xtest format-7.11 {error conditions} {
X catch {format %d 2a}
X} 1
Xtest format-7.12 {error conditions} {
X catch {format %d 2a} msg
X set msg
X} {expected integer but got "2a"}
Xtest format-7.13 {error conditions} {
X catch {format %c 2x}
X} 1
Xtest format-7.14 {error conditions} {
X catch {format %c 2x} msg
X set msg
X} {expected integer but got "2x"}
Xtest format-7.15 {error conditions} {
X catch {format %f 2.1z}
X} 1
Xtest format-7.16 {error conditions} {
X catch {format %f 2.1z} msg
X set msg
X} {expected floating-point number but got "2.1z"}
Xtest format-7.17 {error conditions} {
X catch {format ab%}
X} 1
Xtest format-7.18 {error conditions} {
X catch {format ab% 12} msg
X set msg
X} {format string ended in middle of field specifier}
Xtest format-7.19 {error conditions} {
X catch {format %q x}
X} 1
Xtest format-7.20 {error conditions} {
X catch {format %q x} msg
X set msg
X} {bad field specifier "q"}
Xtest format-7.21 {error conditions} {
X catch {format %d}
X} 1
Xtest format-7.22 {error conditions} {
X catch {format %d} msg
X set msg
X} {not enough arguments for all format specifiers}
X
Xtest format-8.1 {long result} {
X set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 \
X3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E \
XF G H I J K L M N O P Q R S T U V W X Y Z}
X format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd \
Xeeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss \
Xtttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF \
XGGGG %s %s %s} $a $a $a
X} {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff \
Xgggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu \
Xvvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG \
X1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 \
X7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H \
XI J K L M N O P Q R S T U V W X Y Z \
X1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 \
X8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I \
XJ K L M N O P Q R S T U V W X Y Z \
X1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 \
X8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I \
XJ K L M N O P Q R S T U V W X Y Z}
END_OF_FILE
if test 11548 -ne `wc -c <'tcl6.1/tests/format.test'`; then
echo shar: \"'tcl6.1/tests/format.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/format.test'
fi
if test -f 'tcl6.1/tests/parse.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/parse.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/parse.test'\" $11404 characters$
sed "s/^X//" >'tcl6.1/tests/parse.test' <<'END_OF_FILE'
X# Commands covered: set (plus basic command syntax)

X# $Header: /user6/ouster/tcl/tests/RCS/parse.test,v 1.21 91/10/31 16:40:37 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc fourArgs {a b c d} {
X global arg1 arg2 arg3 arg4
X set arg1 $a
X set arg2 $b
X set arg3 $c
X set arg4 $d
X}
X
Xproc getArgs args {
X global argv
X set argv $args
X}
X
X# Basic argument parsing.
X
Xtest parse-1.1 {basic argument parsing} {
X set arg1 {}
X fourArgs a b c d
X list $arg1 $arg2 $arg3 $arg4

X} {a b c d}

Xtest parse-1.2 {basic argument parsing} {
X set arg1 {}
X eval "fourArgs 123\v4\f56\r7890"
X list $arg1 $arg2 $arg3 $arg4
X} {123 4 56 7890}
X
X# Quotes.
X
Xtest parse-2.1 {quotes and variable-substitution} {
X getArgs "a b c" d
X set argv

X} {{a b c} d}

Xtest parse-2.2 {quotes and variable-substitution} {
X set a 101
X getArgs "a$a b c"
X set argv
X} {{a101 b c}}
Xtest parse-2.3 {quotes and variable-substitution} {
X set argv "xy[format xabc]"
X set argv
X} {xyxabc}
Xtest parse-2.4 {quotes and variable-substitution} {
X set argv "xy\t"
X set argv
X} xy\t
Xtest parse-2.5 {quotes and variable-substitution} {
X set argv "a b c
Xd e f"
X set argv
X} a\ b\tc\nd\ e\ f
Xtest parse-2.6 {quotes and variable-substitution} {
X set argv a"bcd"e
X set argv
X} {a"bcd"e}
X
X# Braces.
X
Xtest parse-3.1 {braces} {
X getArgs {a b c} d
X set argv

X} "{a b c} d"

Xtest parse-3.2 {braces} {
X set a 101
X set argv {a$a b c}
X set b [string index $argv 1]
X set b
X} {$}
Xtest parse-3.3 {braces} {
X set argv {a[format xyz] b}
X string length $argv
X} 15
Xtest parse-3.4 {braces} {
X set argv {a\nb\}}
X string length $argv
X} 6
Xtest parse-3.5 {braces} {
X set argv {{{{}}}}
X set argv
X} "{{{}}}"
Xtest parse-3.6 {braces} {
X set argv a{{}}b
X set argv
X} "a{{}}b"
Xtest parse-3.7 {braces} {
X set a [format "last]"]
X set a
X} {last]}
X
X# Command substitution.
X
Xtest parse-4.1 {command substitution} {
X set a [format xyz]

X set a
X} xyz

Xtest parse-4.2 {command substitution} {
X set a a[format xyz]b[format q]
X set a
X} axyzbq
Xtest parse-4.3 {command substitution} {
X set a a[
Xset b 22;
Xformat %s $b
X
X]b
X set a
X} a22b
X
X# Variable substitution.
X
Xtest parse-5.1 {variable substitution} {
X set a 123
X set b $a
X set b
X} 123
Xtest parse-5.2 {variable substitution} {
X set a 345
X set b x$a.b
X set b
X} x345.b
Xtest parse-5.3 {variable substitution} {
X set _123z xx
X set b $_123z^
X set b
X} xx^
Xtest parse-5.4 {variable substitution} {
X set a 78
X set b a${a}b
X set b
X} a78b
Xtest parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1
Xtest parse-5.6 {variable substitution} {
X catch {$_non_existent_} msg
X set msg
X} {can't read "_non_existent_": no such variable}
Xtest parse-5.7 {array variable substitution} {
X catch {unset a}
X set a(xyz) 123
X set b $a(xyz)foo
X set b
X} 123foo
Xtest parse-5.8 {array variable substitution} {
X catch {unset a}
X set "a(x y z)" 123
X set b $a(x y z)foo
X set b
X} 123foo
Xtest parse-5.9 {array variable substitution} {
X catch {unset a}; catch {unset qqq}
X set "a(x y z)" qqq
X set $a([format x]\ y [format z]) foo
X set qqq
X} foo
Xtest parse-5.10 {array variable substitution} {
X catch {unset a}
X list [catch {set b $a(22)} msg] $msg
X} {1 {can't read "a(22)": no such variable}}
Xtest parse-5.11 {array variable substitution} {
X set b a$!
X set b
X} {a$!}
Xtest parse-5.12 {array variable substitution} {
X set b a$()
X set b
X} {a$()}
Xcatch {unset a}
Xtest parse-5.13 {array variable substitution} {
X catch {unset a}
X set long {This is a very long variable, long enough to cause storage \
X allocation to occur in Tcl_ParseVar. If that storage isn't getting \
X freed up correctly, then a core leak will occur when this test is \
X run. This text is probably beginning to sound like drivel, but I've \
X run out of things to say and I need more characters still.}
X set a($long) 777
X set b $a($long)
X list $b [array names a]
X} {777 {{This is a very long variable, long enough to cause storage \
X allocation to occur in Tcl_ParseVar. If that storage isn't getting \
X freed up correctly, then a core leak will occur when this test is \
X run. This text is probably beginning to sound like drivel, but I've \
X run out of things to say and I need more characters still.}}}
Xtest parse-5.14 {array variable substitution} {
X catch {unset a}; catch {unset b}; catch {unset a1}
X set a1(22) foo
X set a(foo) bar
X set b $a($a1(22))
X set b
X} bar
Xcatch {unset a}; catch {unset a1}
X
X# Backslash substitution.
X
Xset errNum 1
Xproc bsCheck {char num} {
X global errNum
X test parse-6.$errNum {backslash substitution} {
X scan $char %c value
X set value
X } $num
X set errNum [expr $errNum+1]
X}
X
XbsCheck \b 8
XbsCheck \e 27
XbsCheck \f 12
XbsCheck \n 10
XbsCheck \r 13
XbsCheck \t 9
XbsCheck \v 11
XbsCheck \{ 123
XbsCheck \} 125
XbsCheck \[ 91
XbsCheck \] 93
XbsCheck \$ 36
XbsCheck \ 32
XbsCheck \; 59
XbsCheck \\ 92
XbsCheck \Ca 1
XbsCheck \Ma 225
XbsCheck \CMa 129
XbsCheck \14 12
XbsCheck \00a 97
XbsCheck b\0 98
XbsCheck \x 92
XbsCheck \
Xa 97
X
Xtest parse-7.1 {backslash substitution} {
X set a "\a\c\n\]\}"
X string length $a
X} 7
Xtest parse-7.2 {backslash substitution} {
X set a {\a\c\n\]\}}
X string length $a
X} 10
Xtest parse-7.3 {backslash substitution} {
X set a "abc\
Xdef"
X set a
X} abcdef
Xtest parse-7.4 {backslash substitution} {
X set a {abc\
Xdef}
X set a
X} "abcdef"
Xtest parse-7.5 {backslash substitution} {
X set msg {}
X set a xxx
X set error [catch {if {24 < \
X 35} {set a 22} {set \
X a 33}} msg]
X list $error $msg $a
X} {0 22 22}
X
X# Semi-colon.
X
Xtest parse-8.1 {semi-colons} {
X set b 0
X getArgs a;set b 2
X set argv
X} a
Xtest parse-8.2 {semi-colons} {
X set b 0
X getArgs a;set b 2
X set b
X} 2
Xtest parse-8.3 {semi-colons} {
X getArgs a b ; set b 1
X set argv
X} {a b}
Xtest parse-8.4 {semi-colons} {
X getArgs a b ; set b 1
X set b
X} 1
X
X# The following checks are to ensure that the interpreter's result
X# gets re-initialized by Tcl_Eval in all the right places.
X
Xtest parse-9.1 {result initialization} {concat abc} abc
Xtest parse-9.2 {result initialization} {concat abc; proc foo {} {}} {}
Xtest parse-9.3 {result initialization} {concat abc; proc foo {} $a} {}
Xtest parse-9.4 {result initialization} {proc foo {} [concat abc]} {}
Xtest parse-9.5 {result initialization} {concat abc; } abc
Xtest parse-9.6 {result initialization} {
X eval {
X concat abc
X}} abc
Xtest parse-9.7 {result initialization} {} {}
Xtest parse-9.8 {result initialization} {concat abc; ; ;} abc
X
X# Syntax errors.
X
Xtest parse-10.1 {syntax errors} {catch "set a \{bcd" msg} 1
Xtest parse-10.2 {syntax errors} {
X catch "set a \{bcd" msg
X set msg
X} {missing close-brace}
Xtest parse-10.3 {syntax errors} {catch {set a "bcd} msg} 1
Xtest parse-10.4 {syntax errors} {
X catch {set a "bcd} msg
X set msg
X} {missing "}
Xtest parse-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
Xtest parse-10.6 {syntax errors} {
X catch {set a "bcd"xy} msg
X set msg
X} {extra characters after close-quote}
Xtest parse-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
Xtest parse-10.8 {syntax errors} {
X catch "set a {bcd}xy" msg
X set msg
X} {extra characters after close-brace}
Xtest parse-10.9 {syntax errors} {catch {set a [format abc} msg} 1
Xtest parse-10.10 {syntax errors} {
X catch {set a [format abc} msg
X set msg
X} {missing close-bracket}
Xtest parse-10.11 {syntax errors} {catch gorp-a-lot msg} 1
Xtest parse-10.12 {syntax errors} {
X catch gorp-a-lot msg
X set msg
X} {invalid command name: "gorp-a-lot"}
Xtest parse-10.13 {syntax errors} {
X set a [concat {a}\
X {b}]

X set a
X} {a b}

Xtest parse-10.14 {syntax errors} {catch "concat \{a\}\\\n{b}" msg} 1
Xtest parse-10.15 {syntax errors} {
X catch "concat \{a\}\\\n{b}" msg
X set msg
X} {extra characters after close-brace}
X
X# Long values (stressing storage management)
X
Xset a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee \
Xffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt \
Xuuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH}
X
Xtest parse-11.1 {long values} {
X string length $a
X} 214
Xtest parse-11.2 {long values} {
X llength $a
X} 43
Xtest parse-1a1.3 {long values} {
X set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd \
Xeeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss \
Xtttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH"
X set b
X} $a
Xtest parse-11.4 {long values} {
X set b "$a"
X set b
X} $a
Xtest parse-11.5 {long values} {
X set b [set a]
X set b
X} $a
Xtest parse-11.6 {long values} {
X set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb \
Xcccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq \
Xrrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF \
XGGGG HHHH]
X string length $b
X} 214
Xtest parse-11.7 {long values} {
X set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb \
Xcccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq \
Xrrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF \
XGGGG HHHH]
X llength $b
X} 43
Xtest parse-11.8 {long values} {
X set b
X} $a
Xtest parse-11.9 {long values} {
X set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa \
Xbbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp \
Xqqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE \
XFFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT \
XUUUU VVVV WWWW XXXX YYYY ZZZZ]
X llength $a
X} 62
Xset i 0
Xforeach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa \
Xbbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp \
Xqqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE \
XFFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT \
XUUUU VVVV WWWW XXXX YYYY ZZZZ] {
X set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
X set test $test$test$test$test
X set i [expr $i+1]
X test parse-11.10 {long values} {
X set j
X } $test
X}
Xtest parse-11.10 {test buffer overflow in backslashes in braces} {
X expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
Xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\
Xxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\
Xyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\
X\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\
X\101\101\101\101\101\101\101}}
X} 0
END_OF_FILE
if test 11404 -ne `wc -c <'tcl6.1/tests/parse.test'`; then
echo shar: \"'tcl6.1/tests/parse.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/parse.test'
fi
echo shar: End of archive 10 $of 33$.
cp /dev/null ark10isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:29:50 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 79
Archive-name: tcl/part11
Environment: UNIX

# "End of archive 11 (of 33)."
# Contents: tcl6.1/changes tcl6.1/tclGlob.c tcl6.1/tests/history.test
# Wrapped by karl@one on Tue Nov 12 19:44:20 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/changes' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/changes'\"
else
echo shar: Extracting \"'tcl6.1/changes'\" $14472 characters$
sed "s/^X//" >'tcl6.1/changes' <<'END_OF_FILE'
XRecent user-visible changes to Tcl:
X
X1. No more [command1] [command2] construct for grouping multiple
Xcommands on a single command line.
X
X2. Semi-colon now available for grouping commands on a line.
X
X3. For a command to span multiple lines, must now use backslash-return
Xat the end of each line but the last.
X
X4. "Var" command has been changed to "set".
X
X5. Double-quotes now available as an argument grouping character.
X
X6. "Return" may be used at top-level.
X
X7. More backslash sequences available now. In particular, backslash-newline
Xmay be used to join lines in command files.
X
X8. New or modified built-in commands: case, return, for, glob, info,
Xprint, return, set, source, string, uplevel.
X
X9. After an error, the variable "errorInfo" is filled with a stack
Xtrace showing what was being executed when the error occurred.
X
X10. Command abbreviations are accepted when parsing commands, but
Xare not recommended except for purely-interactive commands.
X
X11. $, set, and expr all complain now if a non-existent variable is
Xreferenced.
X
X12. History facilities exist now. See Tcl.man and Tcl_RecordAndEval.man.
X
X13. Changed to distinguish between empty variables and those that don't
Xexist at all. Interfaces to Tcl_GetVar and Tcl_ParseVar have changed
X(NULL return value is now possible). *** POTENTIAL INCOMPATIBILITY ***
X
X14. Changed meaning of "level" argument to "uplevel" command (1 now means
X"go up one level", not "go to level 1"; "#1" means "go to level 1").
X*** POTENTIAL INCOMPATIBILITY ***
X
X15. 3/19/90 Added "info exists" option to see if variable exists.
X
X16. 3/19/90 Added "noAbbrev" variable to prohibit command abbreviations.
X
X17. 3/19/90 Added extra errorInfo option to "error" command.
X
X18. 3/21/90 Double-quotes now only affect space: command, variable,
Xand backslash substitutions still occur inside double-quotes.
X*** POTENTIAL INCOMPATIBILITY ***
X
X19. 3/21/90 Added support for \r.
X
X20. 3/21/90 List, concat, eval, and glob commands all expect at least
Xone argument now. *** POTENTIAL INCOMPATIBILITY ***
X
X21. 3/22/90 Added "?:" operators to expressions.
X
X22. 3/25/90 Fixed bug in Tcl_Result that caused memory to get trashed.
X
X------------------- Released version 3.1 ---------------------
X
X23. 3/29/90 Fixed bug that caused "file a.b/c ext" to return ".b/c".
X
X24. 3/29/90 Semi-colon is not treated specially when enclosed in
Xdouble-quotes.
X
X------------------- Released version 3.2 ---------------------
X
X25. 4/16/90 Rewrote "exec" not to use select or signals anymore.
XShould be more Sys-V compatible, and no slower in the normal case.
X
X26. 4/18/90 Rewrote "glob" to eliminate GNU code (there's no GNU code
Xleft in Tcl, now), and added Tcl_TildeSubst procedure. Added automatic
Xtilde-substitution in many commands, including "glob".
X
X------------------- Released version 3.3 ---------------------
X
X27. 7/11/90 Added "Tcl_AppendResult" procedure.
X
X28. 7/20/90 "History" with no options now defaults to "history info"
Xrather than to "history redo". Although this is a backward incompatibility,
Xit should only be used interactively and thus shouldn't present any
Xcompatibility problems with scripts.
X
X29. 7/20/90 Added "Tcl_GetInteger", "Tcl_GetDouble", and "Tcl_GetBoolean"
Xprocedures.
X
X30. 7/22/90 Removed "Tcl_WatchInterp" procedure: doesn't seem to be
Xnecessary, since the same effect can be achieved with the deletion
Xcallbacks on individual commands. *** POTENTIAL INCOMPATIBILITY ***
X
X31. 7/23/90 Added variable tracing: Tcl_TraceVar, Tcl_UnTraceVar,
Xand Tcl_VarTraceInfo procedures, "trace" command.
X
X32. 8/9/90 Mailed out list of all bug fixes since 3.3 release.
X
X33. 8/29/90 Fixed bugs in Tcl_Merge relating to backslashes and
Xsemi-colons. Mailed out patch.
X
X34. 9/3/90 Fixed bug in tclBasic.c: quotes weren't quoting ]'s.
XMailed out patch.
X
X35. 9/19/90 Rewrote exec to always use files both for input and
Xoutput to the process. The old pipe-based version didn't work if
Xthe exec'ed process forked a child and then exited: Tcl waited
Xaround for stdout to get closed, which didn't happen until the
Xgrandchild exited.
X
X36. 11/5/90 ERR_IN_PROGRESS flag wasn't being cleared soon enough
Xin Tcl_Eval, allowing error messages from different commands to
Xpile up in $errorInfo. Fixed by re-arranging code in Tcl_Eval that
Xre-initializes result and ERR_IN_PROGRESS flag. Didn't mail out
Xpatch: changes too complicated to describe.
X
X37. 12/19/90 Added Tcl_VarEval procedure as a convenience for
Xassembling and executing Tcl commands.
X
X38. 1/29/91 Fixed core leak in Tcl_AddErrorInfo. Also changed procedure
Xand Tcl_Eval so that first call to Tcl_AddErrorInfo need not come from
XTcl_Eval.
X
X----------------- Released version 5.0 with Tk ------------------
X
X39. 4/3/91 Removed change bars from manual entries, leaving only those
Xthat came after version 3.3 was released.
X
X40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach.
X
X41. 5/23/91 Massive revision to Tcl parser to simplify the implementation
Xof string and floating-point support in expressions. Newlines inside
X[] are now treated as command separators rather than word separators
X(this makes newline treatment consistent throughout Tcl).
X*** POTENTIAL INCOMPATIBILITY ***
X
X42. 5/23/91 Massive rewrite of expression code to support floating-point
Xvalues and simple string comparisons. The C interfaces to expression
Xroutines have changed (Tcl_Expr is replaced by Tcl_ExprLong, Tcl_ExprDouble,
Xetc.), but all old Tcl expression strings should be accepted by the new
Xexpression code.
X*** POTENTIAL INCOMPATIBILITY ***
X
X43. 5/23/91 Modified tclHistory.c to check for negative "keep" value.
X
X44. 5/23/91 Modified Tcl_Backslash to handle backslash-newline. It now
Xreturns 0 to indicate that a backslash sequence should be replaced by
Xno character at all.
X*** POTENTIAL INCOMPATIBILITY ***
X
X45. 5/29/91 Modified to use ANSI C function prototypes. Must set
X"USE_ANSI" switch when compiling to get prototypes.
X
X46. 5/29/91 Completed test suite by providing tests for all of the
Xbuilt-in Tcl commands.
X
X47. 5/29/91 Changed Tcl_Concat to eliminate leading and trailing
Xwhite-space in each of the things it concatenates and to ignore
Xelements that are empty or have only white space in them. This
Xproduces cleaner output from the "concat" command.
X*** POTENTIAL INCOMPATIBILITY ***
X
X48. 5/31/91 Changed "set" command and Tcl_SetVar procedure to return
Xnew value of variable.
X
X49. 6/1/91 Added "while" and "cd" commands.
X
X50. 6/1/91 Changed "exec" to delete the last character of program
Xoutput if it is a newline. In most cases this makes it easier to
Xprocess program-generated output.
X*** POTENTIAL INCOMPATIBILITY ***
X
X51. 6/1/91 Made sure that pointers are never used after freeing them.
X
X52. 6/1/91 Fixed bug in TclWordEnd where it wasn't dealing with
X[] inside quotes correctly.
X
X53. 6/8/91 Fixed exec.test to accept return values of either 1 or
X255 from "false" command.
X
X54. 7/6/91 Massive overhaul of variable management. Associative
Xarrays now available, along with "unset" command (and Tcl_UnsetVar
Xprocedure). Variable traces have been completely reworked:
Xinterfaces different both from Tcl and C, and multiple traces may
Xexist on same variable. Can no longer redefine existing local
Xvariable to be global. Calling sequences have changed slightly
Xfor Tcl_GetVar and Tcl_SetVar ("global" is now "flags"). Tcl_SetVar
Xcan fail and return a NULL result. New forms of variable-manipulation
Xprocedures: Tcl_GetVar2, Tcl_SetVar2, etc. Syntax of variable
X$-notation changed to support array indexing.
X*** POTENTIAL INCOMPATIBILITY ***
X
X55. 7/6/91 Added new list-manipulation procedures: Tcl_ScanElement,
XTcl_ConvertElement, Tcl_AppendElement.
X
X56. 7/12/91 Created new procedure Tcl_EvalFile, which does most of the
Xwork of the "source" command.
X
X57. 7/20/91 Major reworking of "exec" command to allow pipelines,
Xmore redirection, background. Added new procedures Tcl_Fork,
XTcl_WaitPids, Tcl_DetachPids, and Tcl_CreatePipeline. The old
X"< input" notation has been replaced by "<< input" ("<" is for
Xredirection from a file). Also handles error returns and abnormal
Xterminations (e.g. signals) differently.
X*** POTENTIAL INCOMPATIBILITY ***
X
X58. 7/21/91 Added "append" and "lappend" commands.
X
X59. 7/22/91 Reworked error messages and manual entries to use
X?x? as the notation for an optional argument x, instead of [x]. The
Xbracket notation was often confused with the use of brackets for
Xcommand substitution. Also modified error messages to be more
Xconsistent.
X
X60. 7/23/91 Tcl_DeleteCommand now returns an indication of whether
Xor not the command actually existed, and the "rename" command uses
Xthis information to return an error if an attempt is made to delete
Xa non-existent command.
X*** POTENTIAL INCOMPATIBILITY ***
X
X61. 7/25/91 Added new "errorCode" mechanism, along with procedures
XTcl_SetErrorCode, Tcl_UnixError, and Tcl_ResetResult. Renamed
XTcl_Return to Tcl_SetResult, but left a #define for Tcl_Return to
Xavoid compatibility problems.
X
X62. 7/26/91 Extended "case" command with alternate syntax where all
Xpatterns and commands are together in a single list argument: makes
Xit easier to write multi-line case statements.
X
X63. 7/27/91 Changed "print" command to perform tilde-substitution on
Xthe file name.
X
X64. 7/27/91 Added "tolower", "toupper", "trim", "trimleft", and "trimright"
Xoptions to "string" command.
X
X65. 7/29/91 Added "atime", "mtime", "size", and "stat" options to "file"
Xcommand.
X
X66. 8/1/91 Added "split" and "join" commands.
X
X67. 8/11/91 Added commands for file I/O, including "open", "close",
X"read", "gets", "puts", "flush", "eof", "seek", and "tell".
X
X68. 8/14/91 Switched to use a hash table for command lookups. Command
Xabbreviations no longer have direct support in the Tcl interpreter, but
Xit should be possible to simulate them with the auto-load features
Xdescribed below. The "noAbbrev" variable is no longer used by Tcl.
X*** POTENTIAL INCOMPATIBILITY ***
X
X68.5 8/15/91 Added support for "unknown" command, which can be used to
Xcomplete abbreviations, auto-load library files, auto-exec shell
Xcommands, etc.
X
X69. 8/15/91 Added -nocomplain switch to "glob" command.
X
X70. 8/20/91 Added "info library" option and TCL_LIBRARY #define. Also
Xadded "info script" option.
X
X71. 8/20/91 Changed "file" command to take "option" argument as first
Xargument (before file name), for consistency with other Tcl commands.
X*** POTENTIAL INCOMPATIBILITY ***
X
X72. 8/20/91 Changed format of information in $errorInfo variable:
Xcomments such as

X ("while" body line 1)

Xare now on separate lines from commands being executed.
X*** POTENTIAL INCOMPATIBILITY ***
X
X73. 8/20/91 Changed Tcl_AppendResult so that it (eventually) frees
Xlarge buffers that it allocates.
X
X74. 8/21/91 Added "linsert", "lreplace", "lsearch", and "lsort"
Xcommands.
X
X75. 8/28/91 Added "incr" and "exit" commands.
X
X76. 8/30/91 Added "regexp" and "regsub" commands.
X
X77. 9/4/91 Changed "dynamic" field in interpreters to "freeProc" (procedure
Xaddress). This allows for alternative storage managers.
X*** POTENTIAL INCOMPATIBILITY ***
X
X78. 9/6/91 Added "index", "length", and "range" options to "string"
Xcommand. Added "lindex", "llength", and "lrange" commands.
X
X79. 9/8/91 Removed "index", "length", "print" and "range" commands.
X"Print" is redundant with "puts", but less general, and the other
Xcommands are replaced with the new commands described in change 78
Xabove.
X*** POTENTIAL INCOMPATIBILITY ***
X
X80. 9/8/91 Changed history revision to occur even when history command
Xis nested; needed in order to allow "history" to be invoked from
X"unknown" procedure.
X
X81. 9/13/91 Changed "panic" not to use vfprintf (it's uglier and less
Xgeneral now, but makes it easier to run Tcl on systems that don't
Xhave vfprintf). Also changed "strerror" not to reclare sys_errlist.
X
X82. 9/19/91 Lots of changes to improve portability to different UNIX
Xsystems, including addition of "config" script to adapt Tcl to the
Xconfiguration of the system it's being compiled on.
X
X83. 9/22/91 Added "pwd" command.
X
X84. 9/22/91 Renamed manual pages so that their filenames are no more
Xthan 14 characters in length, moved to "doc" subdirectory.
X
X85. 9/24/91 Redid manual entries so they contain the supplemental
Xmacros that they need; can just print with "troff -man" or "man"
Xnow.
X
X86. 9/26/91 Created initial version of script library, including
Xa version of "unknown" that does auto-loading, auto-execution, and
Xabbreviation expansion. This library is used by tclTest
Xautomatically. See the "library" manual entry for details.
X
X----------------- Released version 6.0, 9/26/91 ------------------
X
X87. 9/30/91 Made "string tolower" and "string toupper" check case
Xbefore converting: on some systems, "tolower" and "toupper" assume
Xthat character already has particular case.
X
X88. 9/30/91 Fixed bug in Tcl_SetResult: wasn't always setting freeProc
Xcorrecly when called with NULL value. This tended to cause memory
Xallocation errors later.
X
X89. 10/3/91 Added "upvar" command.
X
X90. 10/4/91 Changed "format" so that internally it converts %D to %ld,
X%U to %lu, %O to %lo, and %F to %f. This eliminates some compatibility
Xproblems on some machines without affecting behavior.
X
X91. 10/10/91 Fixed bug in "regsub" that caused core dumps with the -all
Xoption when the last match wasn't at the end of the string.
X
X92. 10/17/91 Fixed problems with backslash sequences: \r support was
Xincomplete and \f and \v weren't supported at all.
X
X93. 10/24/91 Added Tcl_InitHistory procedure.
X
X94. 10/24/91 Changed "regexp" to store "-1 -1" in subMatchVars that
Xdon't match, rather than returning an error.
X
X95. 10/27/91 Modified "regexp" to return actual strings in matchVar
Xand subMatchVars instead of indices. Added "-indices" switch to cause
Xindices to be returned.
X*** POTENTIAL INCOMPATIBILITY ***
X
X96. 10/27/91 Fixed bug in "scan" where it used hardwired constants for
Xsizes of floats and doubles instead of using "sizeof".
X
X97. 10/31/91 Fixed bug in tclParse.c where parse-related error messages
Xweren't being storage-managed correctly, causing spurious free's.
X
X98. 10/31/91 Form feed and vertical tab characters are now considered
Xto be space characters by the parser.
X
X99. 10/31/91 Added TCL_LEAVE_ERR_MSG flag to procedures like Tcl_SetVar.
X
X100. 11/7/91 Fixed bug in "case" where "in" argument couldn't be ommitted
Xif all case branches were embedded in a single list.
X
X101. 11/7/91 Switched to use "pid_t" and "uid_t" and other official
XPOSIC types and function prototypes.
END_OF_FILE
if test 14472 -ne `wc -c <'tcl6.1/changes'`; then
echo shar: \"'tcl6.1/changes'\" unpacked with wrong size!
fi
# end of 'tcl6.1/changes'
fi
if test -f 'tcl6.1/tclGlob.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclGlob.c'\"
else
echo shar: Extracting \"'tcl6.1/tclGlob.c'\" $14435 characters$
sed "s/^X//" >'tcl6.1/tclGlob.c' <<'END_OF_FILE'
X/*
X * tclGlob.c --
X *
X * This file provides procedures and commands for file name
X * manipulation, such as tilde expansion and globbing.
X *
X * Copyright 1990-1991 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/tclGlob.c,v 1.21 91/09/23 11:20:00 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X#include "tclUnix.h"
X
X/*

X * The structure below is used to keep track of a globbing result
X * being built up (i.e. a partial list of file names). The list
X * grows dynamically to be as big as needed.
X */
X
Xtypedef struct {
X char *result; /* Pointer to result area. */
X int totalSpace; /* Total number of characters allocated
X * for result. */
X int spaceUsed; /* Number of characters currently in use
X * to hold the partial result (not including
X * the terminating NULL). */
X int dynamic; /* 0 means result is static space, 1 means
X * it's dynamic. */
X} GlobResult;
X
X/*
X * Declarations for procedures local to this file:
X */
X
Xstatic void AppendResult _ANSI_ARGS_((Tcl_Interp *interp,
X char *dir, char *name, int nameLength));
Xstatic int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, char *dir,
X char *rem));

X
X/*
X *----------------------------------------------------------------------
X *

X * AppendResult --
X *
X * Given two parts of a file name (directory and element within
X * directory), concatenate the two together and append them to
X * the result building up in interp.

X *
X * Results:

X * There is no return value.

X *
X * Side effects:

X * Interp->result gets extended.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XAppendResult(interp, dir, name, nameLength)
X Tcl_Interp *interp; /* Interpreter whose result should be
X * appended to. */
X char *dir; /* Name of directory, with trailing
X * slash (unless the whole string is
X * empty). */
X char *name; /* Name of file withing directory (NOT
X * necessarily null-terminated!). */
X int nameLength; /* Number of characters in name. */
X{
X int dirLength, dirFlags, nameFlags;
X char *p, saved;
X
X /*
X * Next, see if we can put together a valid list element from dir
X * and name by calling Tcl_AppendResult.
X */
X
X if (*dir == 0) {
X dirFlags = 0;
X } else {
X Tcl_ScanElement(dir, &dirFlags);
X }
X saved = name[nameLength];
X name[nameLength] = 0;
X Tcl_ScanElement(name, &nameFlags);
X if ((dirFlags == 0) && (nameFlags == 0)) {

X if (*interp->result != 0) {

X Tcl_AppendResult(interp, " ", dir, name, (char *) NULL);
X } else {
X Tcl_AppendResult(interp, dir, name, (char *) NULL);
X }
X name[nameLength] = saved;
X return;
X }
X
X /*
X * This name has weird characters in it, so we have to convert it to
X * a list element. To do that, we have to merge the characters
X * into a single name. To do that, malloc a buffer to hold everything.
X */
X
X dirLength = strlen(dir);
X p = (char *) ckalloc((unsigned) (dirLength + nameLength + 1));
X strcpy(p, dir);
X strcpy(p+dirLength, name);
X name[nameLength] = saved;
X Tcl_AppendElement(interp, p, 0);
X ckfree(p);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * DoGlob --
X *
X * This recursive procedure forms the heart of the globbing
X * code. It performs a depth-first traversal of the tree
X * given by the path name to be globbed.

X *
X * Results:

X * The return value is a standard Tcl result indicating whether
X * an error occurred in globbing. After a normal return the
X * result in interp will be set to hold all of the file names
X * given by the dir and rem arguments. After an error the
X * result in interp will hold an error message.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XDoGlob(interp, dir, rem)
X Tcl_Interp *interp; /* Interpreter to use for error
X * reporting (e.g. unmatched brace). */
X char *dir; /* Name of a directory at which to
X * start glob expansion. This name
X * is fixed: it doesn't contain any
X * globbing chars. If it's non-empty
X * then it should end with a slash. */
X char *rem; /* Path to glob-expand. */
X{
X /*
X * When this procedure is entered, the name to be globbed may
X * already have been partly expanded by ancestor invocations of
X * DoGlob. The part that's already been expanded is in "dir"
X * (this may initially be empty), and the part still to expand
X * is in "rem". This procedure expands "rem" one level, making
X * recursive calls to itself if there's still more stuff left
X * in the remainder.
X */
X
X register char *p;
X register char c;
X char *openBrace, *closeBrace;
X int gotSpecial, result;
X
X /*
X * When generating information for the next lower call,
X * use static areas if the name is short, and malloc if the name
X * is longer.
X */
X
X#define STATIC_SIZE 200
X
X /*
X * First, find the end of the next element in rem, checking
X * along the way for special globbing characters.
X */
X
X gotSpecial = 0;
X openBrace = closeBrace = NULL;
X for (p = rem; ; p++) {
X c = *p;
X if ((c == '\0') || (c == '/')) {
X break;
X }
X if ((c == '{') && (openBrace == NULL)) {
X openBrace = p;
X }
X if ((c == '}') && (closeBrace == NULL)) {
X closeBrace = p;
X }
X if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) {
X gotSpecial = 1;

X }
X }
X
X /*

X * If there is an open brace in the argument, then make a recursive
X * call for each element between the braces. In this case, the
X * recursive call to DoGlob uses the same "dir" that we got.
X * If there are several brace-pairs in a single name, we just handle
X * one here, and the others will be handled in recursive calls.
X */
X
X if (openBrace != NULL) {
X int remLength, l1, l2;
X char static1[STATIC_SIZE];
X char *element, *newRem;
X
X if (closeBrace == NULL) {
X Tcl_ResetResult(interp);
X interp->result = "unmatched open-brace in file name";
X return TCL_ERROR;
X }
X remLength = strlen(rem) + 1;
X if (remLength <= STATIC_SIZE) {
X newRem = static1;
X } else {
X newRem = (char *) ckalloc((unsigned) remLength);
X }
X l1 = openBrace-rem;
X strncpy(newRem, rem, l1);
X p = openBrace;
X for (p = openBrace; *p != '}'; ) {
X element = p+1;
X for (p = element; ((*p != '}') && (*p != ',')); p++) {
X /* Empty loop body: just find end of this element. */
X }
X l2 = p - element;
X strncpy(newRem+l1, element, l2);
X strcpy(newRem+l1+l2, closeBrace+1);
X if (DoGlob(interp, dir, newRem) != TCL_OK) {

X return TCL_ERROR;
X }
X }

X if (remLength > STATIC_SIZE) {
X ckfree(newRem);
X }
X return TCL_OK;
X }
X
X /*
X * If there were any pattern-matching characters, then scan through
X * the directory to find all the matching names.
X */
X
X if (gotSpecial) {
X DIR *d;
X struct dirent *entryPtr;
X int l1, l2;
X char *pattern, *newDir, *dirName;
X char static1[STATIC_SIZE], static2[STATIC_SIZE];
X struct stat statBuf;
X
X /*
X * Be careful not to do any actual file system operations on a
X * directory named ""; instead, use ".". This is needed because
X * some versions of UNIX don't treat "" like "." automatically.
X */
X
X if (*dir == '\0') {
X dirName = ".";
X } else {
X dirName = dir;
X }
X if ((stat(dirName, &statBuf) != 0)
X || ((statBuf.st_mode & S_IFMT) != S_IFDIR)) {
X return TCL_OK;
X }
X d = opendir(dirName);
X if (d == NULL) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "couldn't read directory \"",
X dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X l1 = strlen(dir);
X l2 = (p - rem);
X if (l2 < STATIC_SIZE) {
X pattern = static2;
X } else {
X pattern = (char *) ckalloc((unsigned) (l2+1));
X }
X strncpy(pattern, rem, l2);
X pattern[l2] = '\0';
X result = TCL_OK;
X while (1) {
X entryPtr = readdir(d);
X if (entryPtr == NULL) {
X break;
X }
X
X /*
X * Don't match names starting with "." unless the "." is
X * present in the pattern.
X */
X
X if ((*entryPtr->d_name == '.') && (*pattern != '.')) {
X continue;
X }
X if (Tcl_StringMatch(entryPtr->d_name, pattern)) {
X int nameLength = strlen(entryPtr->d_name);

X
X if (*p == 0) {

X AppendResult(interp, dir, entryPtr->d_name, nameLength);
X } else {
X if ((l1+nameLength+2) <= STATIC_SIZE) {
X newDir = static1;
X } else {
X newDir = (char *) ckalloc((unsigned) (l1+nameLength+2));
X }
X sprintf(newDir, "%s%s/", dir, entryPtr->d_name);
X result = DoGlob(interp, newDir, p+1);
X if (newDir != static1) {
X ckfree(newDir);
X }

X if (result != TCL_OK) {

X break;
X }
X }
X }

X }
X closedir(d);
X if (pattern != static2) {
X ckfree(pattern);
X }
X return result;
X }
X
X /*
X * This is the simplest case: just another path element. Move
X * it to the dir side and recurse (or just add the name to the
X * list, if we're at the end of the path).
X */
X
X if (*p == 0) {
X AppendResult(interp, dir, rem, p-rem);
X } else {
X int l1, l2;
X char *newDir;
X char static1[STATIC_SIZE];
X
X l1 = strlen(dir);
X l2 = l1 + (p - rem) + 2;
X if (l2 <= STATIC_SIZE) {
X newDir = static1;
X } else {
X newDir = (char *) ckalloc((unsigned) l2);
X }
X strcpy(newDir, dir);
X strncpy(newDir+l1, rem, p-rem);
X newDir[l2-2] = '/';
X newDir[l2-1] = 0;
X result = DoGlob(interp, newDir, p+1);
X if (newDir != static1) {
X ckfree(newDir);
X }

X if (result != TCL_OK) {

X return TCL_ERROR;
X }
X }

X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_TildeSubst --
X *
X * Given a name starting with a tilde, produce a name where
X * the tilde and following characters have been replaced by
X * the home directory location for the named user.

X *
X * Results:

X * The result is a pointer to a static string containing
X * the new name. This name will only persist until the next
X * call to Tcl_TildeSubst; save it if you care about it for
X * the long term. If there was an error in processing the
X * tilde, then an error message is left in interp->result
X * and the return value is NULL.

X *
X * Side effects:

X * None that the caller needs to worry about.

X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_TildeSubst(interp, name)
X Tcl_Interp *interp; /* Interpreter in which to store error
X * message (if necessary). */
X char *name; /* File name, which may begin with "~/"
X * (to indicate current user's home directory)
X * or "~<user>/" (to indicate any user's
X * home directory). */
X{
X#define STATIC_BUF_SIZE 50
X static char staticBuf[STATIC_BUF_SIZE];
X static int curSize = STATIC_BUF_SIZE;
X static char *curBuf = staticBuf;
X char *dir;
X int length;
X int fromPw = 0;

X register char *p;
X

X if (name[0] != '~') {
X return name;
X }
X
X /*
X * First, find the directory name corresponding to the tilde entry.
X */
X
X if ((name[1] == '/') || (name[1] == '\0')) {
X dir = getenv("HOME");
X if (dir == NULL) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "couldn't find HOME environment ",
X "variable to expand \"", name, "\"", (char *) NULL);
X return NULL;
X }
X p = name+1;
X } else {
X struct passwd *pwPtr;
X
X for (p = &name[1]; (*p != 0) && (*p != '/'); p++) {
X /* Null body; just find end of name. */
X }
X length = p-&name[1];
X if (length >= curSize) {
X length = curSize-1;
X }
X memcpy((VOID *) curBuf, (VOID *) name+1, length);
X curBuf[length] = '\0';
X pwPtr = getpwnam(curBuf);
X if (pwPtr == NULL) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "user \"", curBuf,
X "\" doesn't exist", (char *) NULL);
X return NULL;
X }
X dir = pwPtr->pw_dir;
X fromPw = 1;
X }
X
X /*
X * Grow the buffer if necessary to make enough space for the
X * full file name.
X */
X
X length = strlen(dir) + strlen(p);
X if (length >= curSize) {
X if (curBuf != staticBuf) {
X ckfree(curBuf);
X }
X curSize = length + 1;
X curBuf = (char *) ckalloc((unsigned) curSize);
X }
X
X /*
X * Finally, concatenate the directory name with the remainder
X * of the path in the buffer.
X */
X
X strcpy(curBuf, dir);
X strcat(curBuf, p);
X if (fromPw) {
X endpwent();
X }
X return curBuf;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GlobCmd --
X *
X * This procedure is invoked to process the "glob" 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_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 int i, result, noComplain;
X
X if (argc < 2) {
X notEnoughArgs:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?-nocomplain? name ?name ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X noComplain = 0;
X if ((argv[1][0] == '-') && (strcmp(argv[1], "-nocomplain") == 0)) {
X if (argc < 3) {
X goto notEnoughArgs;
X }
X noComplain = 1;
X }
X
X for (i = 1 + noComplain; i < argc; i++) {
X char *thisName;
X
X /*
X * Do special checks for names starting at the root and for
X * names beginning with ~. Then let DoGlob do the rest.
X */
X
X thisName = argv[i];
X if (*thisName == '~') {
X thisName = Tcl_TildeSubst(interp, thisName);
X if (thisName == NULL) {

X return TCL_ERROR;
X }
X }

X if (*thisName == '/') {
X result = DoGlob(interp, "/", thisName+1);
X } else {
X result = DoGlob(interp, "", thisName);
X }

X if (result != TCL_OK) {

X return result;
X }
X }
X if ((*interp->result == 0) && !noComplain) {
X interp->result = "no files matched glob pattern(s)";

X return TCL_ERROR;
X }
X return TCL_OK;
X}
END_OF_FILE

if test 14435 -ne `wc -c <'tcl6.1/tclGlob.c'`; then
echo shar: \"'tcl6.1/tclGlob.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclGlob.c'
fi
if test -f 'tcl6.1/tests/history.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/history.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/history.test'\" $12710 characters$
sed "s/^X//" >'tcl6.1/tests/history.test' <<'END_OF_FILE'
X# Commands covered: history

X# $Header: /sprite/src/lib/tcl/tests/RCS/history.test,v 1.7 91/09/09 11:50:13 ouster Exp $ (Berkeley)
X
Xif {[info commands history] == ""} {
X puts stdout "This version of Tcl was built without the history command;\n"
X puts stdout "history tests will be skipped.\n"
X return
X}

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xset num [history nextid]
Xhistory keep 3
Xhistory add {set a 12345}
Xhistory add {set b [format {A test %s} string]}
Xhistory add {Another test}
X
X# "history event"
X
Xtest history-1.1 {event option} {history event -1} \
X {set b [format {A test %s} string]}
Xtest history-1.2 {event option} {history event $num} \
X {set a 12345}
Xtest history-1.3 {event option} {history event [expr $num+2]} \
X {Another test}
Xtest history-1.4 {event option} {history event set} \
X {set b [format {A test %s} string]}
Xtest history-1.5 {event option} {history e "* a*"} \
X {set a 12345}
Xtest history-1.6 {event option} {catch {history event *gorp} msg} 1
Xtest history-1.7 {event option} {
X catch {history event *gorp} msg
X set msg
X} {no event matches "*gorp"}
Xtest history-1.8 {event option} {history event} \
X {set b [format {A test %s} string]}
Xtest history-1.9 {event option} {catch {history event 123 456} msg} 1
Xtest history-1.10 {event option} {
X catch {history event 123 456} msg
X set msg
X} {wrong # args: should be "history event ?event?"}
X
X# "history redo"
X
Xset a 0
Xhistory redo -2
Xtest history-2.1 {redo option} {set a} 12345
Xset b 0
Xhistory redo
Xtest history-2.2 {redo option} {set b} {A test string}
Xtest history-2.3 {redo option} {catch {history redo -3 -4}} 1
Xtest history-2.4 {redo option} {
X catch {history redo -3 -4} msg
X set msg
X} {wrong # args: should be "history redo ?event?"}
X
X# "history add"
X
Xhistory add "set a 444" exec
Xtest history-3.1 {add option} {set a} 444
Xtest history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1
Xtest history-3.3 {add option} {
X catch {history add "set a 444" execGorp} msg
X set msg
X} {bad argument "execGorp": should be "exec"}
Xtest history-3.4 {add option} {catch {history add "set a 444" a} msg} 1
Xtest history-3.5 {add option} {
X catch {history add "set a 444" a} msg
X set msg
X} {bad argument "a": should be "exec"}
Xhistory add "set a 555" e
Xtest history-3.6 {add option} {set a} 555
Xhistory add "set a 666"
Xtest history-3.7 {add option} {set a} 555
Xtest history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1
Xtest history-3.9 {add option} {
X catch {history add "set a 666" e f} msg
X set msg
X} {wrong # args: should be "history add event ?exec?"}
X
X# "history change"
X
Xhistory change "A test value"
Xtest history-4.1 {change option} {history event [expr {[history n]-1}]} \
X "A test value"
Xhistory c "Another test" -1
Xtest history-4.2 {change option} {history e} "Another test"
Xtest history-4.3 {change option} {history event [expr {[history n]-1}]} \
X "A test value"
Xtest history-4.4 {change option} {catch {history change Foo 4 10}} 1
Xtest history-4.5 {change option} {
X catch {history change Foo 4 10} msg
X set msg
X} {wrong # args: should be "history change newValue ?event?"}
Xtest history-4.6 {change option} {
X catch {history change Foo [expr {[history n]-4}]}
X} 1
Xtest history-4.7 {change option} {
X catch {history change Foo [expr {[history n]-4}]}
X set msg
X} {wrong # args: should be "history change newValue ?event?"}
X
X# "history info"
X
Xset num [history n]
Xhistory add set\ a\ {b\nc\ d\ e}
Xhistory add {set b 1234}
Xhistory add set\ c\ {a\nb\nc}
Xtest history-5.1 {info option} {history info} [format {%6d set a {b
X c d e}
X%6d set b 1234
X%6d set c {a
X b
X c}} $num [expr $num+1] [expr $num+2]]
Xtest history-5.2 {info option} {history i 2} [format {%6d set b 1234
X%6d set c {a
X b
X c}} [expr $num+1] [expr $num+2]]
Xtest history-5.3 {info option} {catch {history i 2 3}} 1
Xtest history-5.4 {info option} {
X catch {history i 2 3} msg
X set msg
X} {wrong # args: should be "history info ?count?"}
Xtest history-5.5 {info option} {history} [format {%6d set a {b
X c d e}
X%6d set b 1234
X%6d set c {a
X b
X c}} $num [expr $num+1] [expr $num+2]]
X
X# "history keep"
X
Xhistory add "foo1"
Xhistory add "foo2"
Xhistory add "foo3"
Xhistory keep 2
Xtest history-6.1 {keep option} {history event [expr [history n]-1]} foo3
Xtest history-6.2 {keep option} {history event -1} foo2
Xtest history-6.3 {keep option} {catch {history event -3}} 1
Xtest history-6.4 {keep option} {
X catch {history event -3} msg
X set msg
X} {event "-3" is too far in the past}
Xhistory k 5
Xtest history-6.5 {keep option} {history event -1} foo2
Xtest history-6.6 {keep option} {history event -2} {}
Xtest history-6.7 {keep option} {history event -3} {}
Xtest history-6.8 {keep option} {history event -4} {}
Xtest history-6.9 {keep option} {catch {history event -5}} 1
Xtest history-6.10 {keep option} {catch {history keep 4 6}} 1
Xtest history-6.11 {keep option} {
X catch {history keep 4 6} msg
X set msg
X} {wrong # args: should be "history keep number"}
Xtest history-6.12 {keep option} {catch {history keep}} 1
Xtest history-6.13 {keep option} {
X catch {history keep} msg
X set msg
X} {wrong # args: should be "history keep number"}
Xtest history-6.14 {keep option} {catch {history keep -3}} 1
Xtest history-6.15 {keep option} {
X catch {history keep -3} msg
X set msg
X} {illegal keep count "-3"}
X
X# "history nextid"
X
Xset num [history n]
Xhistory add "Testing"
Xhistory add "Testing2"
Xtest history-7.1 {nextid option} {history event} "Testing"
Xtest history-7.2 {nextid option} {history next} [expr $num+2]
Xtest history-7.3 {nextid option} {catch {history nextid garbage}} 1
Xtest history-7.4 {nextid option} {
X catch {history nextid garbage} msg
X set msg
X} {wrong # args: should be "history nextid"}
X
X# "history substitute"
X
Xtest history-8.1 {substitute option} {
X history add "set a {test foo test b c test}"
X history add "Test command 2"
X set a 0
X history substitute foo bar -1
X set a
X} {test bar test b c test}
Xtest history-8.2 {substitute option} {
X history add "set a {test foo test b c test}"
X history add "Test command 2"
X set a 0
X history substitute test gorp
X set a
X} {gorp foo gorp b c gorp}
Xtest history-8.3 {substitute option} {
X history add "set a {test foo test b c test}"
X history add "Test command 2"
X set a 0
X history sub " te" to
X set a
X} {test footost b ctost}
Xtest history-8.4 {substitute option} {catch {history sub xxx yyy}} 1
Xtest history-8.5 {substitute option} {
X catch {history sub xxx yyy} msg
X set msg
X} {"xxx" doesn't appear in event}
Xtest history-8.6 {substitute option} {catch {history s a b -10}} 1
Xtest history-8.7 {substitute option} {
X catch {history s a b -10} msg
X set msg
X} {event "-10" is too far in the past}
Xtest history-8.8 {substitute option} {catch {history s a b -1 20}} 1
Xtest history-8.9 {substitute option} {
X catch {history s a b -1 20} msg
X set msg
X} {wrong # args: should be "history substitute old new ?event?"}
X
X# "history words"
X
Xtest history-9.1 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history words 0-$
X} {word0 word1 word2 a b c word6}
Xtest history-9.2 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history w 2 -1
X} word2
Xtest history-9.3 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history wo $
X} word6
Xtest history-9.4 {words option} {catch {history w 1--1} msg} 1
Xtest history-9.5 {words option} {
X catch {history w 1--1} msg
X set msg
X} {bad word selector "1--1": should be num-num or pattern}
Xtest history-9.6 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history w w
X} {}
Xtest history-9.7 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history w *2
X} word2
Xtest history-9.8 {words option} {
X history add {word0 word1 word2 a b c word6}
X history add foo
X history w *or*
X} {word0 word1 word2 word6}
Xtest history-9.9 {words option} {catch {history words 10}} 1
Xtest history-9.10 {words option} {
X catch {history words 10} msg
X set msg
X} {word selector "10" specified non-existent words}
Xtest history-9.11 {words option} {catch {history words 1 -1 20}} 1
Xtest history-9.12 {words option} {
X catch {history words 1 -1 20} msg
X set msg
X} {wrong # args: should be "history words num-num/pat ?event?"}
X
X# history revision
X
Xtest history-10.1 {history revision} {
X set a 0
X history a {set a 12345}
X history a {set a [history e]} exec
X set a
X} {set a 12345}
Xtest history-10.2 {history revision} {
X set a 0
X history a {set a 12345}
X history a {set a [history e]} exec
X history a foo
X history ev -1
X} {set a {set a 12345}}
Xtest history-10.3 {history revision} {
X set a 0
X history a {set a 12345}
X history a {set a [history e]} exec
X history a foo
X history a {history r -2} exec
X history a {set a 12345}
X history ev -1
X} {set a {set a 12345}}
Xtest history-10.4 {history revision} {
X history a {set a 12345}
X history a {history s 123 999} exec
X history a foo
X history ev -1
X} {set a 99945}
Xtest history-10.5 {history revision} {
X history add {word0 word1 word2 a b c word6}
X history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
X set a
X} {word0 {a b}}
Xtest history-10.6 {history revision} {
X history add {word0 word1 word2 a b c word6}
X history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
X history add foo
X history ev
X} {set a [list word0 {a b}]}
Xtest history-10.7 {history revision} {
X history add {word0 word1 word2 a b c word6}
X history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec
X history add {format b}
X history add {word0 word1 word2 a b c word6}
X set a 0
X history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec
X history add foo
X history ev
X} {set [format a] [list abc [format b] {word1 word2 a}]}
Xtest history-10.8 {history revision} {
X history add {set a 12345}

X concat a b c

X history add {history redo; set b 44} exec
X history add foo
X history ev
X} {set a 12345; set b 44}
Xtest history-10.9 {history revision} {
X history add {set a 12345}
X history add {history redo; history change "A simple test"; history subs 45 xx} exec
X set a
X} 123xx
Xtest history-10.10 {history revision} {
X history add {set a 12345}
X history add {history redo; history change "A simple test"; history subs 45 xx} exec
X history add foo
X history e
X} {A simple test}
Xtest history-10.11 {history revision} {
X history add {word0 word1 $ a b c word6}
X history add {set a [history w 4-[history word 2]]} exec
X set a
X} {b c word6}
Xtest history-10.12 {history revision} {
X history add {word0 word1 $ a b c word6}
X history add {set a [history w 4-[history word 2]]} exec
X history add foo
X history e
X} {set a {b c word6}}
Xtest history-10.13 {history revision} {
X history add {history word 0} exec
X history add foo
X history e
X} {history word 0}
Xtest history-10.14 {history revision} {
X history add {set a [history word 0; format c]} exec
X history add foo
X history e
X} {set a [history word 0; format c]}
Xtest history-10.15 {history revision even when nested} {
X proc x {a b} {history word $a $b}
X history add {word1 word2 word3 word4}
X history add {set a [x 1-3 -1]} exec
X history add foo
X history e
X} {set a {word2 word3 word4}}
Xtest history-10.16 {disable history revision in nested history evals} {
X history add {word1 word2 word3 word4}
X history add {set a [history words 0]; history add foo; set a [history words 0]} exec
X history e
X} {set a word1; history add foo; set a [history words 0]}
X
X# miscellaneous
X
Xtest history-11.1 {miscellaneous} {catch {history gorp} msg} 1
Xtest history-11.2 {miscellaneous} {
X catch {history gorp} msg
X set msg
X} {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words}
END_OF_FILE
if test 12710 -ne `wc -c <'tcl6.1/tests/history.test'`; then
echo shar: \"'tcl6.1/tests/history.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/history.test'
fi
echo shar: End of archive 11 $of 33$.
cp /dev/null ark11isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:30:28 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 80
Archive-name: tcl/part12
Environment: UNIX

# "End of archive 12 (of 33)."
# Contents: tcl6.1/tclCkalloc.c tcl6.1/tclProc.c tcl6.1/tclUnixStr.c
# Wrapped by karl@one on Tue Nov 12 19:44:20 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclCkalloc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclCkalloc.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCkalloc.c'\" $15293 characters$
sed "s/^X//" >'tcl6.1/tclCkalloc.c' <<'END_OF_FILE'
X/*
X * tclCkalloc.c --
X * Interface to malloc and free that provides support for debugging problems
X * involving overwritten, double freeing memory and loss of memory.

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 * This code contributed by Karl Lehenbauer and Mark Diekhans

X *
X */
X
X#include "tclInt.h"
X#include "tclUnix.h"
X

X#define FALSE 0
X#define TRUE 1
X
X#ifdef TCL_MEM_DEBUG
X
X#define GUARD_SIZE 8
X
Xstruct mem_header {
X long length;
X char *file;
X int line;
X struct mem_header *flink;
X struct mem_header *blink;
X unsigned char low_guard[GUARD_SIZE];
X char body[1];
X};
X
Xstatic struct mem_header *allocHead = NULL; /* List of allocated structures */
X
X#define GUARD_VALUE 0341
X
X/* static char high_guard[] = {0x89, 0xab, 0xcd, 0xef}; */
X
Xstatic int total_mallocs = 0;
Xstatic int total_frees = 0;
Xstatic int current_bytes_malloced = 0;
Xstatic int maximum_bytes_malloced = 0;
Xstatic int current_malloc_packets = 0;
Xstatic int maximum_malloc_packets = 0;
Xstatic int break_on_malloc = 0;
Xstatic int trace_on_at_malloc = 0;
Xstatic int alloc_tracing = FALSE;
Xstatic int init_malloced_bodies = FALSE;
X#ifdef MEM_VALIDATE
X static int validate_memory = TRUE;
X#else
X static int validate_memory = FALSE;
X#endif
X

X
X/*
X *----------------------------------------------------------------------
X *

X * dump_memory_info --
X * Display the global memory management statistics.

X *
X *----------------------------------------------------------------------
X */

Xstatic void
Xdump_memory_info(outFile)
X FILE *outFile;
X{
X fprintf(outFile,"total mallocs %10d\n",
X total_mallocs);
X fprintf(outFile,"total frees %10d\n",
X total_frees);
X fprintf(outFile,"current packets allocated %10d\n",
X current_malloc_packets);
X fprintf(outFile,"current bytes allocated %10d\n",
X current_bytes_malloced);
X fprintf(outFile,"maximum packets allocated %10d\n",
X maximum_malloc_packets);
X fprintf(outFile,"maximum bytes allocated %10d\n",
X maximum_bytes_malloced);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * ValidateMemory --
X * Procedure to validate allocted memory guard zones.

X *
X *----------------------------------------------------------------------
X */

Xstatic void
XValidateMemory (memHeaderP, file, line, nukeGuards)
X struct mem_header *memHeaderP;
X char *file;
X int line;
X int nukeGuards;
X{
X unsigned char *hiPtr;
X int idx;
X int guard_failed = FALSE;
X
X for (idx = 0; idx < GUARD_SIZE; idx++)
X if (*(memHeaderP->low_guard + idx) != GUARD_VALUE) {
X guard_failed = TRUE;
X fflush (stdout);
X fprintf(stderr, "low guard byte %d is 0x%x\n", idx,
X *(memHeaderP->low_guard + idx) & 0xff);
X }
X
X if (guard_failed) {
X dump_memory_info (stderr);
X fprintf (stderr, "low guard failed at %lx, %s %d\n",
X memHeaderP->body, file, line);
X fflush (stderr); /* In case name pointer is bad. */
X fprintf (stderr, "Allocated at (%s %d)\n", memHeaderP->file,
X memHeaderP->line);
X panic ("Memory validation failure");
X }
X
X hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
X for (idx = 0; idx < GUARD_SIZE; idx++)
X if (*(hiPtr + idx) != GUARD_VALUE) {
X guard_failed = TRUE;
X fflush (stdout);
X fprintf(stderr, "hi guard byte %d is 0x%x\n", idx,
X *(hiPtr+idx) & 0xff);
X }
X
X if (guard_failed) {
X dump_memory_info (stderr);
X fprintf (stderr, "high guard failed at %lx, %s %d\n",
X memHeaderP->body, file, line);
X fflush (stderr); /* In case name pointer is bad. */
X fprintf (stderr, "Allocated at (%s %d)\n", memHeaderP->file,
X memHeaderP->line);
X panic ("Memory validation failure");
X }
X
X if (nukeGuards) {
X memset ((char *) memHeaderP->low_guard, 0, GUARD_SIZE);
X memset ((char *) hiPtr, 0, GUARD_SIZE);
X }
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ValidateAllMemory --
X * Validates guard regions for all allocated memory.

X *
X *----------------------------------------------------------------------
X */

Xvoid
XTcl_ValidateAllMemory (file, line)
X char *file;
X int line;
X{
X struct mem_header *memScanP;
X
X for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
X ValidateMemory (memScanP, file, line, FALSE);
X
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DumpActiveMemory --
X * Displays all allocated memory to stderr.

X *
X * Results:

X * Return TCL_ERROR if an error accessing the file occures, `errno'
X * will have the file error number left in it.
X *----------------------------------------------------------------------
X */
Xint
XTcl_DumpActiveMemory (fileName)
X char *fileName;
X{
X FILE *fileP;
X struct mem_header *memScanP;
X char *address;
X
X fileP = fopen (fileName, "w");
X if (fileP == NULL)
X return TCL_ERROR;
X
X for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
X address = &memScanP->body [0];
X fprintf (fileP, "%8lx - %8lx %7d @ %s %d\n", address,
X address + memScanP->length - 1, memScanP->length,
X memScanP->file, memScanP->line);
X }
X fclose (fileP);
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DbCkalloc - debugging ckalloc
X *
X * Allocate the requested amount of space plus some extra for
X * guard bands at both ends of the request, plus a size, panicing
X * if there isn't enough space, then write in the guard bands
X * and return the address of the space in the middle that the
X * user asked for.
X *
X * The second and third arguments are file and line, these contain
X * the filename and line number corresponding to the caller.
X * These are sent by the ckalloc macro; it uses the preprocessor
X * autodefines __FILE__ and __LINE__.

X *
X *----------------------------------------------------------------------
X */

Xchar *
XTcl_DbCkalloc(size, file, line)
X unsigned int size;
X char *file;
X int line;
X{
X struct mem_header *result;
X
X if (validate_memory)
X Tcl_ValidateAllMemory (file, line);
X
X result = (struct mem_header *)malloc((unsigned)size +
X sizeof(struct mem_header) + GUARD_SIZE);
X if (result == NULL) {
X fflush(stdout);
X dump_memory_info(stderr);
X panic("unable to alloc %d bytes, %s line %d", size, file,
X line);
X }
X
X /*
X * Fill in guard zones and size. Link into allocated list.
X */
X result->length = size;
X result->file = file;
X result->line = line;
X memset ((char *) result->low_guard, GUARD_VALUE, GUARD_SIZE);
X memset (result->body + size, GUARD_VALUE, GUARD_SIZE);
X result->flink = allocHead;
X result->blink = NULL;
X if (allocHead != NULL)
X allocHead->blink = result;
X allocHead = result;
X
X total_mallocs++;
X if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
X (void) fflush(stdout);
X fprintf(stderr, "reached malloc trace enable point (%d)\n",
X total_mallocs);
X fflush(stderr);
X alloc_tracing = TRUE;
X trace_on_at_malloc = 0;
X }
X
X if (alloc_tracing)
X fprintf(stderr,"ckalloc %lx %d %s %d\n", result->body, size,
X file, line);
X
X if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
X break_on_malloc = 0;
X (void) fflush(stdout);
X fprintf(stderr,"reached malloc break limit (%d)\n",
X total_mallocs);
X fprintf(stderr, "program will now enter C debugger\n");
X (void) fflush(stderr);
X kill (getpid(), SIGINT);
X }
X
X current_malloc_packets++;
X if (current_malloc_packets > maximum_malloc_packets)
X maximum_malloc_packets = current_malloc_packets;
X current_bytes_malloced += size;
X if (current_bytes_malloced > maximum_bytes_malloced)
X maximum_bytes_malloced = current_bytes_malloced;
X
X if (init_malloced_bodies)
X memset (result->body, 0xff, (int) size);
X
X return result->body;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DbCkfree - debugging ckfree
X *
X * Verify that the low and high guards are intact, and if so
X * then free the buffer else panic.
X *
X * The guards are erased after being checked to catch duplicate
X * frees.
X *
X * The second and third arguments are file and line, these contain
X * the filename and line number corresponding to the caller.
X * These are sent by the ckfree macro; it uses the preprocessor
X * autodefines __FILE__ and __LINE__.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_DbCkfree(ptr, file, line)
X char * ptr;
X char *file;
X int line;
X{
X struct mem_header *memp = 0; /* Must be zero for size calc */
X
X /*
X * Since header ptr is zero, body offset will be size
X */
X memp = (struct mem_header *)(((char *) ptr) - (int)memp->body);
X
X if (alloc_tracing)
X fprintf(stderr, "ckfree %lx %ld %s %d\n", memp->body,
X memp->length, file, line);
X
X if (validate_memory)
X Tcl_ValidateAllMemory (file, line);
X
X ValidateMemory (memp, file, line, TRUE);
X
X total_frees++;
X current_malloc_packets--;
X current_bytes_malloced -= memp->length;
X
X /*
X * Delink from allocated list
X */
X if (memp->flink != NULL)
X memp->flink->blink = memp->blink;
X if (memp->blink != NULL)
X memp->blink->flink = memp->flink;
X if (allocHead == memp)
X allocHead = memp->flink;
X free((char *) memp);
X return 0;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * MemoryCmd --
X * Implements the TCL memory command:
X * memory info
X * memory display
X * break_on_malloc count
X * trace_on_at_malloc count
X * trace on|off
X * validate on|off

X *
X * Results:

X * Standard TCL results.

X *
X *----------------------------------------------------------------------
X */

X /* ARGSUSED */
Xstatic int
XMemoryCmd (clientData, interp, argc, argv)
X char *clientData;
X Tcl_Interp *interp;

X int argc;
X char **argv;
X{

X char *fileName;

X
X if (argc < 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " option [args..]\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X if (strcmp(argv[1],"trace") == 0) {
X if (argc != 3)
X goto bad_suboption;
X alloc_tracing = (strcmp(argv[2],"on") == 0);
X return TCL_OK;
X }
X if (strcmp(argv[1],"init") == 0) {
X if (argc != 3)
X goto bad_suboption;
X init_malloced_bodies = (strcmp(argv[2],"on") == 0);
X return TCL_OK;
X }
X if (strcmp(argv[1],"validate") == 0) {
X if (argc != 3)
X goto bad_suboption;
X validate_memory = (strcmp(argv[2],"on") == 0);
X return TCL_OK;
X }
X if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
X if (argc != 3)
X goto argError;
X if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK)
X return TCL_ERROR;
X return TCL_OK;
X }
X if (strcmp(argv[1],"break_on_malloc") == 0) {
X if (argc != 3)
X goto argError;
X if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK)
X return TCL_ERROR;

X return TCL_OK;
X }
X

X if (strcmp(argv[1],"info") == 0) {
X dump_memory_info(stdout);
X return TCL_OK;
X }
X if (strcmp(argv[1],"active") == 0) {
X if (argc != 3) {
X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " active file", (char *) NULL);
X return TCL_ERROR;
X }
X fileName = argv [2];
X if (fileName [0] == '~')
X if ((fileName = Tcl_TildeSubst (interp, fileName)) == NULL)
X return TCL_ERROR;
X if (Tcl_DumpActiveMemory (fileName) != TCL_OK) {
X Tcl_AppendResult(interp, "error accessing ", argv[2],
X (char *) NULL);
X return TCL_ERROR;
X }
X return TCL_OK;
X }
X Tcl_AppendResult(interp, "bad option \"", argv[1],
X "\": should be info, init, active, break_on_malloc, ",
X "trace_on_at_malloc, trace, or validate", (char *) NULL);
X return TCL_ERROR;
X
XargError:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ", argv[1], "count\"", (char *) NULL);
X return TCL_ERROR;
X
Xbad_suboption:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ", argv[1], " on|off\"", (char *) NULL);
X return TCL_ERROR;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_InitMemory --
X * Initialize the memory command.

X *
X *----------------------------------------------------------------------
X */

Xvoid
XTcl_InitMemory(interp)
X Tcl_Interp *interp;
X{
XTcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData)NULL,
X (void (*)())NULL);
X}
X
X#else
X

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_Ckalloc --
X * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check
X * that memory was actually allocated.

X *
X *----------------------------------------------------------------------
X */

XVOID *
XTcl_Ckalloc (size)
X unsigned int size;
X{
X char *result;
X
X result = malloc(size);
X if (result == NULL)
X panic("unable to alloc %d bytes", size);
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * TckCkfree --
X * Interface to free when TCL_MEM_DEBUG is disabled. Done here rather
X * in the macro to keep some modules from being compiled with
X * TCL_MEM_DEBUG enabled and some with it disabled.

X *
X *----------------------------------------------------------------------
X */

Xvoid
XTcl_Ckfree (ptr)
X VOID *ptr;
X{
X free (ptr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_InitMemory --
X * Dummy initialization for memory command, which is only available
X * if TCL_MEM_DEBUG is on.

X *
X *----------------------------------------------------------------------
X */

X /* ARGSUSED */
Xvoid
XTcl_InitMemory(interp)
X Tcl_Interp *interp;
X{
X}
X
X#endif
X
END_OF_FILE
if test 15293 -ne `wc -c <'tcl6.1/tclCkalloc.c'`; then
echo shar: \"'tcl6.1/tclCkalloc.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCkalloc.c'
fi
if test -f 'tcl6.1/tclProc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclProc.c'\"
else
echo shar: Extracting \"'tcl6.1/tclProc.c'\" $14709 characters$
sed "s/^X//" >'tcl6.1/tclProc.c' <<'END_OF_FILE'
X/*
X * tclProc.c --
X *
X * This file contains routines that implement Tcl procedures,
X * including the "proc" and "uplevel" commands.
X *
X * Copyright 1987-1991 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.59 91/09/30 16:59:54 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * Forward references to procedures defined later in this file:
X */
X
Xstatic int InterpProc _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, int argc, char **argv));
Xstatic void ProcDeleteProc _ANSI_ARGS_((ClientData clientData));

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 = NULL;
X Arg *lastArgPtr;
X register Arg *argPtr = NULL; /* Initialization not needed, but
X * prevents compiler warning. */
X
X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " name args body\"", (char *) NULL);

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
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 goto procError;
X }
X lastArgPtr = NULL;
X for (i = 0; i < argCount; i++) {
X int fieldCount, nameLength, valueLength;
X char **fieldValues;
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 ckfree((char *) fieldValues);
X Tcl_AppendResult(interp,
X "too many fields in argument specifier \"",
X argArray[i], "\"", (char *) NULL);
X result = TCL_ERROR;
X goto procError;
X }
X if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
X ckfree((char *) fieldValues);
X Tcl_AppendResult(interp, "procedure \"", argv[1],
X "\" has argument with no name", (char *) NULL);
X result = TCL_ERROR;
X goto procError;
X }
X nameLength = strlen(fieldValues[0]) + 1;
X if (fieldCount == 2) {
X valueLength = strlen(fieldValues[1]) + 1;
X } else {
X valueLength = 0;
X }
X argPtr = (Arg *) ckalloc((unsigned)
X (sizeof(Arg) - sizeof(argPtr->name) + nameLength
X + valueLength));
X if (lastArgPtr == NULL) {
X procPtr->argPtr = argPtr;
X } else {
X lastArgPtr->nextPtr = argPtr;
X }
X lastArgPtr = argPtr;
X argPtr->nextPtr = NULL;
X strcpy(argPtr->name, fieldValues[0]);
X if (fieldCount == 2) {
X argPtr->defValue = argPtr->name + nameLength;
X strcpy(argPtr->defValue, fieldValues[1]);
X } else {
X argPtr->defValue = NULL;
X }
X ckfree((char *) fieldValues);
X }
X
X Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
X ProcDeleteProc);
X ckfree((char *) argArray);
X return TCL_OK;
X
X procError:
X ckfree(procPtr->command);
X while (procPtr->argPtr != NULL) {
X argPtr = procPtr->argPtr;
X procPtr->argPtr = argPtr->nextPtr;
X ckfree((char *) argPtr);
X }
X ckfree((char *) procPtr);
X if (argArray != NULL) {
X ckfree((char *) argArray);

X }
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * TclGetFrame --
X *
X * Given a description of a procedure frame, such as the first
X * argument to an "uplevel" or "upvar" command, locate the
X * call frame for the appropriate level of procedure.
X *
X * Results:
X * The return value is -1 if an error occurred in finding the
X * frame (in this case an error message is left in interp->result).
X * 1 is returned if string was either a number or a number preceded
X * by "#" and it specified a valid frame. 0 is returned if string
X * isn't one of the two things above (in this case, the lookup
X * acts as if string were "1"). The variable pointed to by
X * framePtrPtr is filled in with the address of the desired frame
X * (unless an error occurs, in which case it isn't modified).

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xint
XTclGetFrame(interp, string, framePtrPtr)
X Tcl_Interp *interp; /* Interpreter in which to find frame. */
X char *string; /* String describing frame. */
X CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
X * if global frame indicated). */
X{
X register Interp *iPtr = (Interp *) interp;
X int level, result;
X CallFrame *framePtr;
X
X if (iPtr->varFramePtr == NULL) {
X iPtr->result = "already at top level";
X return -1;
X }
X
X /*
X * Parse string to figure out which level number to go to.
X */
X
X result = 1;
X if (*string == '#') {
X if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
X return -1;
X }
X if (level < 0) {
X levelError:
X Tcl_AppendResult(interp, "bad level \"", string, "\"",
X (char *) NULL);
X return -1;
X }
X } else if (isdigit(*string)) {
X if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
X return -1;
X }
X level = iPtr->varFramePtr->level - level;
X } else {
X level = iPtr->varFramePtr->level - 1;
X result = 0;
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 if (level == 0) {
X framePtr = NULL;
X } else {
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 }
X *framePtrPtr = framePtr;
X return result;
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 result;
X CallFrame *savedVarFramePtr, *framePtr;

X
X if (argc < 2) {

X uplevelSyntax:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?level? command ?command ...?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X /*
X * Find the level to use for executing the command.
X */
X
X result = TclGetFrame(interp, argv[1], &framePtr);
X if (result == -1) {
X return TCL_ERROR;
X }
X argc -= (result+1);
X argv += (result+1);
X
X /*
X * Modify the interpreter state to execute in the given frame.
X */
X
X savedVarFramePtr = iPtr->varFramePtr;
X iPtr->varFramePtr = framePtr;
X
X /*
X * Execute the residual arguments as a command.
X */
X
X if (argc == 0) {
X goto uplevelSyntax;
X }
X if (argc == 1) {
X result = Tcl_Eval(interp, argv[0], 0, (char **) NULL);
X } else {
X char *cmd;
X
X cmd = Tcl_Concat(argc, argv);
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, "\n (\"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 Tcl_HashEntry *hPtr;
X Command *cmdPtr;
X
X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
X if (hPtr == NULL) {
X return NULL;
X }
X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
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 * 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

Xstatic int
XInterpProc(clientData, interp, argc, argv)
X ClientData clientData; /* 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 register Proc *procPtr = (Proc *) clientData;
X register Arg *argPtr;
X register Interp *iPtr = (Interp *) interp;
X char **args;
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 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
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 (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
X argPtr != NULL;
X argPtr = argPtr->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 ((argPtr->nextPtr == NULL)
X && (strcmp(argPtr->name, "args") == 0)) {
X if (argc < 0) {
X argc = 0;
X }
X value = Tcl_Merge(argc, args);
X Tcl_SetVar(interp, argPtr->name, value, 0);
X ckfree(value);
X argc = 0;
X break;
X } else if (argc > 0) {
X value = *args;
X } else if (argPtr->defValue != NULL) {
X value = argPtr->defValue;
X } else {
X Tcl_AppendResult(interp, "no value given for parameter \"",
X argPtr->name, "\" to \"", argv[0], "\"",
X (char *) NULL);
X result = TCL_ERROR;
X goto procDone;
X }
X Tcl_SetVar(interp, argPtr->name, value, 0);
X }
X if (argc > 0) {
X Tcl_AppendResult(interp, "called \"", argv[0],
X "\" with too many arguments", (char *) NULL);
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, "\n (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 (it's
X * important to remove the call frame from the interpreter
X * before deleting it, so that traces invoked during the
X * deletion don't see the partially-deleted frame).
X */
X
X procDone:
X iPtr->framePtr = frame.callerPtr;
X iPtr->varFramePtr = frame.callerVarPtr;
X TclDeleteVars(iPtr, &frame.varTable);
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

Xstatic void
XProcDeleteProc(clientData)
X ClientData clientData; /* Procedure to be deleted. */
X{
X register Proc *procPtr = (Proc *) clientData;
X register Arg *argPtr;
X
X ckfree((char *) procPtr->command);
X for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
X Arg *nextPtr = argPtr->nextPtr;
X
X ckfree((char *) argPtr);
X argPtr = nextPtr;
X }
X ckfree((char *) procPtr);
X}
END_OF_FILE
if test 14709 -ne `wc -c <'tcl6.1/tclProc.c'`; then
echo shar: \"'tcl6.1/tclProc.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclProc.c'
fi
if test -f 'tcl6.1/tclUnixStr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclUnixStr.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUnixStr.c'\" $14884 characters$
sed "s/^X//" >'tcl6.1/tclUnixStr.c' <<'END_OF_FILE'
X/*
X * tclUnixStr.c --
X *
X * This file contains procedures that generate strings
X * corresponding to various UNIX-related codes, such
X * as errno and signals.

Xstatic char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclUnixStr.c,v 1.6 91/09/30 09:07:57 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X#include "tclUnix.h"

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ErrnoId --
X *
X * Return a textual identifier for the current errno value.

X *
X * Results:

X * This procedure returns a machine-readable textual identifier
X * that corresponds to the current errno value (e.g. "EPERM").
X * The identifier is the same as the #define name in errno.h.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_ErrnoId()
X{
X switch (errno) {
X#ifdef E2BIG
X case E2BIG: return "E2BIG";
X#endif
X#ifdef EACCES
X case EACCES: return "EACCES";
X#endif
X#ifdef EADDRINUSE
X case EADDRINUSE: return "EADDRINUSE";
X#endif
X#ifdef EADDRNOTAVAIL
X case EADDRNOTAVAIL: return "EADDRNOTAVAIL";
X#endif
X#ifdef EADV
X case EADV: return "EADV";
X#endif
X#ifdef EAFNOSUPPORT
X case EAFNOSUPPORT: return "EAFNOSUPPORT";
X#endif
X#ifdef EAGAIN
X case EAGAIN: return "EAGAIN";

X#endif
X#ifdef EALIGN
X case EALIGN: return "EALIGN";
X#endif
X#ifdef EALREADY

X case EALREADY: return "EALREADY";
X#endif
X#ifdef EBADE
X case EBADE: return "EBADE";
X#endif
X#ifdef EBADF
X case EBADF: return "EBADF";
X#endif
X#ifdef EBADFD
X case EBADFD: return "EBADFD";
X#endif
X#ifdef EBADMSG
X case EBADMSG: return "EBADMSG";
X#endif
X#ifdef EBADR
X case EBADR: return "EBADR";
X#endif
X#ifdef EBADRPC
X case EBADRPC: return "EBADRPC";
X#endif
X#ifdef EBADRQC
X case EBADRQC: return "EBADRQC";
X#endif
X#ifdef EBADSLT
X case EBADSLT: return "EBADSLT";
X#endif
X#ifdef EBFONT
X case EBFONT: return "EBFONT";
X#endif
X#ifdef EBUSY
X case EBUSY: return "EBUSY";
X#endif
X#ifdef ECHILD
X case ECHILD: return "ECHILD";
X#endif
X#ifdef ECHRNG
X case ECHRNG: return "ECHRNG";
X#endif
X#ifdef ECOMM
X case ECOMM: return "ECOMM";
X#endif
X#ifdef ECONNABORTED
X case ECONNABORTED: return "ECONNABORTED";
X#endif
X#ifdef ECONNREFUSED
X case ECONNREFUSED: return "ECONNREFUSED";
X#endif
X#ifdef ECONNRESET
X case ECONNRESET: return "ECONNRESET";

X#endif
X#ifdef EDEADLK
X#ifndef EWOULDBLOCK

X case EDEADLK: return "EDEADLK";

X#else
X#if EWOULDBLOCK != EDEADLK

X case EDEADLK: return "EDEADLK";

X#endif /* EWOULDBLOCK != EDEADLK */
X#endif /* EWOULDBLOCK */
X#endif /* EDEADLK */
X#ifdef EDEADLOCK

X case EDEADLOCK: return "EDEADLOCK";
X#endif
X#ifdef EDESTADDRREQ
X case EDESTADDRREQ: return "EDESTADDRREQ";
X#endif
X#ifdef EDIRTY
X case EDIRTY: return "EDIRTY";
X#endif
X#ifdef EDOM
X case EDOM: return "EDOM";
X#endif
X#ifdef EDOTDOT
X case EDOTDOT: return "EDOTDOT";
X#endif
X#ifdef EDQUOT
X case EDQUOT: return "EDQUOT";
X#endif
X#ifdef EDUPPKG
X case EDUPPKG: return "EDUPPKG";
X#endif
X#ifdef EEXIST
X case EEXIST: return "EEXIST";
X#endif
X#ifdef EFAULT
X case EFAULT: return "EFAULT";
X#endif
X#ifdef EFBIG
X case EFBIG: return "EFBIG";
X#endif
X#ifdef EHOSTDOWN
X case EHOSTDOWN: return "EHOSTDOWN";
X#endif
X#ifdef EHOSTUNREACH
X case EHOSTUNREACH: return "EHOSTUNREACH";
X#endif
X#ifdef EIDRM
X case EIDRM: return "EIDRM";
X#endif
X#ifdef EINIT
X case EINIT: return "EINIT";
X#endif
X#ifdef EINPROGRESS
X case EINPROGRESS: return "EINPROGRESS";
X#endif
X#ifdef EINTR
X case EINTR: return "EINTR";
X#endif
X#ifdef EINVAL
X case EINVAL: return "EINVAL";
X#endif
X#ifdef EIO
X case EIO: return "EIO";
X#endif
X#ifdef EISCONN
X case EISCONN: return "EISCONN";
X#endif
X#ifdef EISDIR
X case EISDIR: return "EISDIR";
X#endif
X#ifdef EISNAME
X case EISNAM: return "EISNAM";

X#endif
X#ifdef ELBIN
X case ELBIN: return "ELBIN";
X#endif
X#ifdef EL2HLT

X case EL2HLT: return "EL2HLT";
X#endif
X#ifdef EL2NSYNC
X case EL2NSYNC: return "EL2NSYNC";
X#endif
X#ifdef EL3HLT
X case EL3HLT: return "EL3HLT";
X#endif
X#ifdef EL3RST
X case EL3RST: return "EL3RST";
X#endif
X#ifdef ELIBACC
X case ELIBACC: return "ELIBACC";
X#endif
X#ifdef ELIBBAD
X case ELIBBAD: return "ELIBBAD";
X#endif
X#ifdef ELIBEXEC
X case ELIBEXEC: return "ELIBEXEC";
X#endif
X#ifdef ELIBMAX
X case ELIBMAX: return "ELIBMAX";
X#endif
X#ifdef ELIBSCN
X case ELIBSCN: return "ELIBSCN";
X#endif
X#ifdef ELNRNG
X case ELNRNG: return "ELNRNG";
X#endif
X#ifdef ELOOP
X case ELOOP: return "ELOOP";
X#endif
X#ifdef EMFILE
X case EMFILE: return "EMFILE";
X#endif
X#ifdef EMLINK
X case EMLINK: return "EMLINK";
X#endif
X#ifdef EMSGSIZE
X case EMSGSIZE: return "EMSGSIZE";
X#endif
X#ifdef EMULTIHOP
X case EMULTIHOP: return "EMULTIHOP";
X#endif
X#ifdef ENAMETOOLONG
X case ENAMETOOLONG: return "ENAMETOOLONG";
X#endif
X#ifdef ENAVAIL
X case ENAVAIL: return "ENAVAIL";

X#endif
X#ifdef ENET
X case ENET: return "ENET";
X#endif
X#ifdef ENETDOWN

X case ENETDOWN: return "ENETDOWN";
X#endif
X#ifdef ENETRESET
X case ENETRESET: return "ENETRESET";
X#endif
X#ifdef ENETUNREACH
X case ENETUNREACH: return "ENETUNREACH";
X#endif
X#ifdef ENFILE
X case ENFILE: return "ENFILE";
X#endif
X#ifdef ENOANO
X case ENOANO: return "ENOANO";

X#endif
X#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR))

X case ENOBUFS: return "ENOBUFS";
X#endif
X#ifdef ENOCSI
X case ENOCSI: return "ENOCSI";
X#endif
X#ifdef ENODATA
X case ENODATA: return "ENODATA";
X#endif
X#ifdef ENODEV
X case ENODEV: return "ENODEV";
X#endif
X#ifdef ENOENT
X case ENOENT: return "ENOENT";
X#endif
X#ifdef ENOEXEC
X case ENOEXEC: return "ENOEXEC";
X#endif
X#ifdef ENOLCK
X case ENOLCK: return "ENOLCK";
X#endif
X#ifdef ENOLINK
X case ENOLINK: return "ENOLINK";
X#endif
X#ifdef ENOMEM
X case ENOMEM: return "ENOMEM";
X#endif
X#ifdef ENOMSG
X case ENOMSG: return "ENOMSG";
X#endif
X#ifdef ENONET
X case ENONET: return "ENONET";
X#endif
X#ifdef ENOPKG
X case ENOPKG: return "ENOPKG";
X#endif
X#ifdef ENOPROTOOPT
X case ENOPROTOOPT: return "ENOPROTOOPT";
X#endif
X#ifdef ENOSPC
X case ENOSPC: return "ENOSPC";
X#endif
X#ifdef ENOSR
X case ENOSR: return "ENOSR";
X#endif
X#ifdef ENOSTR
X case ENOSTR: return "ENOSTR";
X#endif
X#ifdef ENOSYM
X case ENOSYM: return "ENOSYM";
X#endif
X#ifdef ENOSYS
X case ENOSYS: return "ENOSYS";
X#endif
X#ifdef ENOTBLK
X case ENOTBLK: return "ENOTBLK";
X#endif
X#ifdef ENOTCONN
X case ENOTCONN: return "ENOTCONN";
X#endif
X#ifdef ENOTDIR
X case ENOTDIR: return "ENOTDIR";
X#endif
X#ifdef ENOTEMPTY
X case ENOTEMPTY: return "ENOTEMPTY";
X#endif
X#ifdef ENOTNAM
X case ENOTNAM: return "ENOTNAM";
X#endif
X#ifdef ENOTSOCK
X case ENOTSOCK: return "ENOTSOCK";
X#endif
X#ifdef ENOTTY
X case ENOTTY: return "ENOTTY";
X#endif
X#ifdef ENOTUNIQ
X case ENOTUNIQ: return "ENOTUNIQ";
X#endif
X#ifdef ENXIO
X case ENXIO: return "ENXIO";
X#endif
X#ifdef EOPNOTSUPP
X case EOPNOTSUPP: return "EOPNOTSUPP";
X#endif
X#ifdef EPERM
X case EPERM: return "EPERM";
X#endif
X#ifdef EPFNOSUPPORT
X case EPFNOSUPPORT: return "EPFNOSUPPORT";
X#endif
X#ifdef EPIPE
X case EPIPE: return "EPIPE";
X#endif
X#ifdef EPROCLIM
X case EPROCLIM: return "EPROCLIM";
X#endif
X#ifdef EPROCUNAVAIL
X case EPROCUNAVAIL: return "EPROCUNAVAIL";
X#endif
X#ifdef EPROGMISMATCH
X case EPROGMISMATCH: return "EPROGMISMATCH";
X#endif
X#ifdef EPROGUNAVAIL
X case EPROGUNAVAIL: return "EPROGUNAVAIL";
X#endif
X#ifdef EPROTO
X case EPROTO: return "EPROTO";
X#endif
X#ifdef EPROTONOSUPPORT
X case EPROTONOSUPPORT: return "EPROTONOSUPPORT";
X#endif
X#ifdef EPROTOTYPE
X case EPROTOTYPE: return "EPROTOTYPE";
X#endif
X#ifdef ERANGE
X case ERANGE: return "ERANGE";
X#endif
X#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED))

X case EREFUSED: return "EREFUSED";
X#endif
X#ifdef EREMCHG

X case EREMCHG: return "EREMCHG";
X#endif
X#ifdef EREMDEV
X case EREMDEV: return "EREMDEV";
X#endif
X#ifdef EREMOTE
X case EREMOTE: return "EREMOTE";
X#endif
X#ifdef EREMOTEIO
X case EREMOTEIO: return "EREMOTEIO";

X#endif
X#ifdef EREMOTERELEASE
X case EREMOTERELEASE: return "EREMOTERELEASE";
X#endif
X#ifdef EROFS

X case EROFS: return "EROFS";
X#endif
X#ifdef ERPCMISMATCH
X case ERPCMISMATCH: return "ERPCMISMATCH";
X#endif
X#ifdef ERREMOTE
X case ERREMOTE: return "ERREMOTE";
X#endif
X#ifdef ESHUTDOWN
X case ESHUTDOWN: return "ESHUTDOWN";
X#endif
X#ifdef ESOCKTNOSUPPORT
X case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT";
X#endif
X#ifdef ESPIPE
X case ESPIPE: return "ESPIPE";
X#endif
X#ifdef ESRCH
X case ESRCH: return "ESRCH";
X#endif
X#ifdef ESRMNT
X case ESRMNT: return "ESRMNT";
X#endif
X#ifdef ESTALE
X case ESTALE: return "ESTALE";
X#endif
X#ifdef ESUCCESS
X case ESUCCESS: return "ESUCCESS";
X#endif
X#ifdef ETIME
X case ETIME: return "ETIME";
X#endif
X#ifdef ETIMEDOUT
X case ETIMEDOUT: return "ETIMEDOUT";
X#endif
X#ifdef ETOOMANYREFS
X case ETOOMANYREFS: return "ETOOMANYREFS";
X#endif
X#ifdef ETXTBSY
X case ETXTBSY: return "ETXTBSY";
X#endif
X#ifdef EUCLEAN
X case EUCLEAN: return "EUCLEAN";
X#endif
X#ifdef EUNATCH
X case EUNATCH: return "EUNATCH";
X#endif
X#ifdef EUSERS
X case EUSERS: return "EUSERS";
X#endif
X#ifdef EVERSION
X case EVERSION: return "EVERSION";
X#endif
X#ifdef EWOULDBLOCK
X case EWOULDBLOCK: return "EWOULDBLOCK";
X#endif
X#ifdef EXDEV
X case EXDEV: return "EXDEV";
X#endif
X#ifdef EXFULL
X case EXFULL: return "EXFULL";
X#endif
X }
X return "unknown error";
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SignalId --
X *
X * Return a textual identifier for a signal number.

X *
X * Results:

X * This procedure returns a machine-readable textual identifier
X * that corresponds to sig. The identifier is the same as the
X * #define name in signal.h.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_SignalId(sig)
X int sig; /* Number of signal. */
X{
X switch (sig) {
X#ifndef SIGIOT
X#ifdef SIGABRT
X case SIGABRT: return "SIGABRT";
X#endif
X#endif /* SIGIOT */
X#ifdef SIGALRM
X case SIGALRM: return "SIGALRM";
X#endif
X#ifdef SIGBUS
X case SIGBUS: return "SIGBUS";
X#endif
X#ifdef SIGCHLD
X case SIGCHLD: return "SIGCHLD";
X#endif
X#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
X case SIGCLD: return "SIGCLD";
X#endif
X#ifdef SIGCONT
X case SIGCONT: return "SIGCONT";
X#endif
X#ifdef SIGEMT
X case SIGEMT: return "SIGEMT";
X#endif
X#ifdef SIGFPE
X case SIGFPE: return "SIGFPE";
X#endif
X#ifdef SIGHUP
X case SIGHUP: return "SIGHUP";
X#endif
X#ifdef SIGILL
X case SIGILL: return "SIGILL";
X#endif
X#ifdef SIGINT
X case SIGINT: return "SIGINT";
X#endif
X#ifdef SIGIO
X case SIGIO: return "SIGIO";
X#endif
X#ifdef SIGIOT
X case SIGIOT: return "SIGIOT";
X#endif
X#ifdef SIGKILL
X case SIGKILL: return "SIGKILL";
X#endif
X#ifdef SIGLOST
X case SIGLOST: return "SIGLOST";
X#endif
X#ifdef SIGPIPE
X case SIGPIPE: return "SIGPIPE";
X#endif
X#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
X case SIGPOLL: return "SIGPOLL";
X#endif
X#ifdef SIGPROF
X case SIGPROF: return "SIGPROF";
X#endif
X#ifdef SIGPWR
X case SIGPWR: return "SIGPWR";
X#endif
X#ifdef SIGQUIT
X case SIGQUIT: return "SIGQUIT";
X#endif
X#ifdef SIGSEGV
X case SIGSEGV: return "SIGSEGV";
X#endif
X#ifdef SIGSTOP
X case SIGSTOP: return "SIGSTOP";
X#endif
X#ifdef SIGSYS
X case SIGSYS: return "SIGSYS";
X#endif
X#ifdef SIGTERM
X case SIGTERM: return "SIGTERM";
X#endif
X#ifdef SIGTRAP
X case SIGTRAP: return "SIGTRAP";
X#endif
X#ifdef SIGTSTP
X case SIGTSTP: return "SIGTSTP";
X#endif
X#ifdef SIGTTIN
X case SIGTTIN: return "SIGTTIN";
X#endif
X#ifdef SIGTTOU
X case SIGTTOU: return "SIGTTOU";
X#endif
X#ifdef SIGURG
X case SIGURG: return "SIGURG";
X#endif
X#ifdef SIGUSR1
X case SIGUSR1: return "SIGUSR1";
X#endif
X#ifdef SIGUSR2
X case SIGUSR2: return "SIGUSR2";
X#endif
X#ifdef SIGVTALRM
X case SIGVTALRM: return "SIGVTALRM";
X#endif
X#ifdef SIGWINCH
X case SIGWINCH: return "SIGWINCH";
X#endif
X#ifdef SIGXCPU
X case SIGXCPU: return "SIGXCPU";
X#endif
X#ifdef SIGXFSZ
X case SIGXFSZ: return "SIGXFSZ";
X#endif
X }
X return "unknown signal";
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SignalMsg --
X *
X * Return a human-readable message describing a signal.

X *
X * Results:

X * This procedure returns a string describing sig that should
X * make sense to a human. It may not be easy for a machine
X * to parse.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_SignalMsg(sig)
X int sig; /* Number of signal. */
X{
X switch (sig) {
X#ifndef SIGIOT
X#ifdef SIGABRT
X case SIGABRT: return "SIGABRT";
X#endif
X#endif /* SIGIOT */
X#ifdef SIGALRM
X case SIGALRM: return "alarm clock";
X#endif
X#ifdef SIGBUS
X case SIGBUS: return "bus error";
X#endif
X#ifdef SIGCHLD
X case SIGCHLD: return "child status changed";
X#endif
X#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD))
X case SIGCLD: return "child status changed";
X#endif
X#ifdef SIGCONT
X case SIGCONT: return "continue after stop";
X#endif
X#ifdef SIGEMT
X case SIGEMT: return "EMT instruction";
X#endif
X#ifdef SIGFPE
X case SIGFPE: return "floating-point exception";
X#endif
X#ifdef SIGHUP
X case SIGHUP: return "hangup";
X#endif
X#ifdef SIGILL
X case SIGILL: return "illegal instruction";
X#endif
X#ifdef SIGINT
X case SIGINT: return "interrupt";
X#endif
X#ifdef SIGIO
X case SIGIO: return "input/output possible on file";
X#endif
X#ifdef SIGIOT
X case SIGIOT: return "IOT instruction";
X#endif
X#ifdef SIGKILL
X case SIGKILL: return "kill signal";
X#endif
X#ifdef SIGLOST
X case SIGLOST: return "resource lost";
X#endif
X#ifdef SIGPIPE
X case SIGPIPE: return "write on pipe with no readers";
X#endif
X#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO))
X case SIGPOLL: return "input/output possible on file";
X#endif
X#ifdef SIGPROF
X case SIGPROF: return "profiling alarm";
X#endif
X#ifdef SIGPWR
X case SIGPWR: return "power-fail restart";
X#endif
X#ifdef SIGQUIT
X case SIGQUIT: return "quit signal";
X#endif
X#ifdef SIGSEGV
X case SIGSEGV: return "segmentation violation";
X#endif
X#ifdef SIGSTOP
X case SIGSTOP: return "stop";
X#endif
X#ifdef SIGSYS
X case SIGSYS: return "bad argument to system call";
X#endif
X#ifdef SIGTERM
X case SIGTERM: return "software termination signal";
X#endif
X#ifdef SIGTRAP
X case SIGTRAP: return "trace trap";
X#endif
X#ifdef SIGTSTP
X case SIGTSTP: return "stop signal from tty";
X#endif
X#ifdef SIGTTIN
X case SIGTTIN: return "background tty read";
X#endif
X#ifdef SIGTTOU
X case SIGTTOU: return "background tty write";
X#endif
X#ifdef SIGURG
X case SIGURG: return "urgent I/O condition";
X#endif
X#ifdef SIGUSR1
X case SIGUSR1: return "user-defined signal 1";
X#endif
X#ifdef SIGUSR2
X case SIGUSR2: return "user-defined signal 2";
X#endif
X#ifdef SIGVTALRM
X case SIGVTALRM: return "virtual time alarm";
X#endif
X#ifdef SIGWINCH
X case SIGWINCH: return "window changed";
X#endif
X#ifdef SIGXCPU
X case SIGXCPU: return "exceeded CPU time limit";
X#endif
X#ifdef SIGXFSZ
X case SIGXFSZ: return "exceeded file size limit";
X#endif
X }
X return "unknown signal";
X}
END_OF_FILE
if test 14884 -ne `wc -c <'tcl6.1/tclUnixStr.c'`; then
echo shar: \"'tcl6.1/tclUnixStr.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUnixStr.c'
fi
echo shar: End of archive 12 $of 33$.
cp /dev/null ark12isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:31:00 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 81
Archive-name: tcl/part13
Environment: UNIX

# "End of archive 13 (of 33)."
# Contents: tcl6.1/tests/open.test tcl6.1/tests/set.test
# Wrapped by karl@one on Tue Nov 12 19:44:22 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tests/open.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/open.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/open.test'\" $16158 characters$
sed "s/^X//" >'tcl6.1/tests/open.test' <<'END_OF_FILE'
X# Commands covered: open, close, gets, puts, read, seek, tell, eof, flush

X# $Header: /sprite/src/lib/tcl/tests/RCS/open.test,v 1.8 91/09/24 16:17:00 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xcatch {exec rm -f test1 test2 test3}
Xexec cat > test1 << "Two lines: this one\nand this one\n"
Xexec cat > test2 << "line1\nline2\nline3\nline4\nline5\n"
X
Xtest open-1.1 {open command (files only)} {
X set f [open test1]
X set x [gets $f]
X close $f
X set x
X} {Two lines: this one}
Xtest open-1.2 {open command (files only)} {
X set f [open test1]
X set f2 [open test2]
X set f3 [open test1]
X set f4 [open test1]
X set x [list [gets $f] [gets $f2] [gets $f3] [gets $f4] \
X [gets $f] [gets $f2]]
X close $f
X close $f2
X close $f3
X close $f4
X set x
X} {{Two lines: this one} line1 {Two lines: this one} {Two lines: this one} {and this one} line2}
Xtest open-1.3 {open command (files only)} {
X set f [open test3 w]
X puts $f xyz
X close $f
X exec cat test3
X} "xyz"
Xtest open-1.4 {open command (files only)} {
X set f [open test3 w]
X puts $f xyz
X close $f
X set f [open test3 a]
X puts $f 123
X close $f
X exec cat test3
X} "xyz\n123"
Xtest open-1.5 {open command (files only)} {
X set f [open test3 w]
X puts $f xyz\n123
X close $f
X set f [open test3 r+]
X set x [gets $f]
X seek $f 0 current
X puts $f 456
X close $f
X list $x [exec cat test3]
X} "xyz {xyz
X456}"
Xtest open-1.6 {open command (files only)} {
X set f [open test3 w]
X puts $f xyz\n123
X close $f
X set f [open test3 w+]
X puts $f xyzzy
X seek $f 2
X set x [gets $f]
X close $f
X list $x [exec cat test3]
X} "zzy xyzzy"
Xtest open-1.7 {open command (files only)} {
X set f [open test3 w]
X puts $f xyz\n123
X close $f
X set f [open test3 a+]
X puts $f xyzzy
X flush $f
X set x [tell $f]
X seek $f -4 cur
X set y [gets $f]
X close $f
X list $x [exec cat test3] $y
X} {14 {xyz
X123
Xxyzzy} zzy}
X
Xtest open-2.1 {errors in open command} {
X list [catch {open} msg] $msg
X} {1 {wrong # args: should be "open filename ?access?"}}
Xtest open-2.2 {errors in open command} {
X list [catch {open a b c} msg] $msg
X} {1 {wrong # args: should be "open filename ?access?"}}
Xtest open-2.3 {errors in open command} {
X list [catch {open test1 x} msg] $msg
X} {1 {illegal access mode "x"}}
Xtest open-2.4 {errors in open command} {
X list [catch {open test1 rw} msg] $msg
X} {1 {illegal access mode "rw"}}
Xtest open-2.5 {errors in open command} {
X list [catch {open test1 r+1} msg] $msg
X} {1 {illegal access mode "r+1"}}
Xtest open-2.6 {errors in open command} {
X string tolower [list [catch {open _non_existent_} msg] $msg $errorCode]
X} {1 {couldn't open "_non_existent_": no such file or directory} {unix enoent {no such file or directory}}}
X
Xif {![file exists ~/_test_] && [file writable ~]} {
X test open-3.1 {tilde substitution in open} {
X set f [open ~/_test_ w]
X puts $f "Some text"
X close $f
X set x [file exists $env(HOME)/_test_]
X exec rm -f $env(HOME)/_test_

X set x
X } 1

X}
Xtest open-3.2 {tilde substitution in open} {

X set home $env(HOME)
X unset env(HOME)

X set x [list [catch {open ~/foo} msg] $msg]

X set env(HOME) $home
X set x

X} {1 {couldn't find HOME environment variable to expand "~/foo"}}
X
Xtest open-4.1 {file id parsing errors} {
X list [catch {eof gorp} msg] $msg $errorCode
X} {1 {bad file identifier "gorp"} NONE}
Xtest open-4.2 {file id parsing errors} {
X list [catch {eof filex} msg] $msg
X} {1 {bad file identifier "filex"}}
Xtest open-4.3 {file id parsing errors} {
X list [catch {eof file12a} msg] $msg
X} {1 {bad file identifier "file12a"}}
Xtest open-4.4 {file id parsing errors} {
X list [catch {eof file123} msg] $msg
X} {1 {file "file123" isn't open}}
Xtest open-4.5 {file id parsing errors} {
X list [catch {eof file1} msg] $msg
X} {0 0}
Xtest open-4.5 {file id parsing errors} {
X list [catch {eof stdin} msg] $msg
X} {0 0}
Xtest open-4.6 {file id parsing errors} {
X list [catch {eof stdout} msg] $msg
X} {0 0}
Xtest open-4.7 {file id parsing errors} {
X list [catch {eof stderr} msg] $msg
X} {0 0}
Xtest open-4.8 {file id parsing errors} {
X list [catch {eof stderr1} msg] $msg
X} {1 {bad file identifier "stderr1"}}
Xset f [open test1]
Xclose $f
Xset expect "1 {file \"$f\" isn't open}"
Xtest open-4.9 {file id parsing errors} {
X list [catch {eof $f} msg] $msg
X} $expect
X
Xtest open-5.1 {close command (files only)} {
X list [catch {close} msg] $msg $errorCode
X} {1 {wrong # args: should be "close fileId"} NONE}
Xtest open-5.2 {close command (files only)} {
X list [catch {close a b} msg] $msg $errorCode
X} {1 {wrong # args: should be "close fileId"} NONE}
Xtest open-5.3 {close command (files only)} {
X list [catch {close gorp} msg] $msg $errorCode
X} {1 {bad file identifier "gorp"} NONE}
Xtest open-5.4 {close command (files only)} {
X list [catch {close file4} msg] \
X [string range $msg [string first {" } $msg] end] $errorCode
X} {1 {" isn't open} NONE}
X
Xtest open-6.1 {puts command} {
X list [catch {puts file3} msg] $msg $errorCode
X} {1 {wrong # args: should be "puts fileId string ?nonewline?"} NONE}
Xtest open-6.2 {puts command} {
X list [catch {puts a b c d} msg] $msg $errorCode
X} {1 {wrong # args: should be "puts fileId string ?nonewline?"} NONE}
Xtest open-6.3 {puts command} {
X list [catch {puts a b nonewlinx} msg] $msg $errorCode
X} {1 {bad argument "nonewlinx": should be "nonewline"} NONE}
Xtest open-6.4 {puts command} {
X list [catch {puts gorp "New text"} msg] $msg $errorCode
X} {1 {bad file identifier "gorp"} NONE}
Xtest open-6.5 {puts command} {
X set f [open test3]
X set x [list [catch {puts $f "New text"} msg] \
X [string range $msg [string first " " $msg] end] $errorCode]
X close $f
X set x
X} {1 { wasn't opened for writing} NONE}
Xtest open-6.6 {puts command} {
X set f [open test3 w]
X puts $f "Text1" n
X puts $f " Text 2" no
X puts $f " Text 3"
X close $f
X exec cat test3
X} {Text1 Text 2 Text 3}
X
Xtest open-7.1 {gets command} {
X list [catch {gets} msg] $msg $errorCode
X} {1 {wrong # args: should be "gets fileId ?varName?"} NONE}
Xtest open-7.2 {gets command} {
X list [catch {gets a b c} msg] $msg $errorCode
X} {1 {wrong # args: should be "gets fileId ?varName?"} NONE}
Xtest open-7.3 {gets command} {
X list [catch {gets a} msg] $msg $errorCode
X} {1 {bad file identifier "a"} NONE}
Xtest open-7.4 {gets command} {
X set f [open test3 w]
X set x [list [catch {gets $f} msg] \
X [string range $msg [string first " " $msg] end] $errorCode]
X close $f
X set x
X} {1 { wasn't opened for reading} NONE}
Xset f [open test3 w]
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" nonewline
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" nonewline
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" nonewline
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" nonewline
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Xclose $f
Xtest open-7.5 {gets command with long line} {
X set f [open test3]
X set x [gets $f]
X close $f
X set x
X} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
Xtest open-7.6 {gets command with long line} {
X set f [open test3]
X set x [gets $f y]
X close $f
X list $x $y
X} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
Xtest open-7.7 {gets command and end of file} {
X set f [open test3 w]
X puts $f "Test1\nTest2" nonewline
X close $f
X set f [open test3]
X set x {}
X set y {}
X lappend x [gets $f y] $y
X set y {}
X lappend x [gets $f y] $y
X set y {}
X lappend x [gets $f y] $y
X close $f
X set x
X} {5 Test1 5 Test2 -1 {}}
X
Xtest open-8.1 {read command} {
X list [catch {read} msg] $msg $errorCode
X} {1 {wrong # args: should be "read fileId ?numBytes|nonewline?"} NONE}
Xtest open-8.2 {read command} {
X list [catch {read a b c} msg] $msg $errorCode
X} {1 {wrong # args: should be "read fileId ?numBytes|nonewline?"} NONE}
Xtest open-8.3 {read command} {
X list [catch {read file10} msg] $msg $errorCode
X} {1 {file "file10" isn't open} NONE}
Xtest open-8.4 {read command} {
X set f [open test3 w]
X set x [list [catch {read $f} msg] \
X [string range $msg [string first " " $msg] end] $errorCode]
X close $f
X set x
X} {1 { wasn't opened for reading} NONE}
Xtest open-8.5 {read command} {
X set f [open test1]
X set x [list [catch {read $f 12z} msg] $msg $errorCode]
X close $f
X set x
X} {1 {expected integer but got "12z"} NONE}
Xtest open-8.6 {read command} {
X set f [open test1]
X set x [list [catch {read $f z} msg] $msg $errorCode]
X close $f
X set x
X} {1 {bad argument "z": should be "nonewline"} NONE}
Xtest open-8.7 {read command} {
X set f [open test1]
X set x [list [read $f 1] [read $f 2] [read $f]]
X close $f
X set x
X} {T wo { lines: this one
Xand this one
X}}
Xtest open-8.8 {read command, with over-large count} {
X set f [open test1]
X set x [read $f 100]
X close $f
X set x
X} {Two lines: this one
Xand this one
X}
Xtest open-8.9 {read command, nonewline option} {
X set f [open test1]
X set x [read $f n]
X close $f
X set x
X} {Two lines: this one
Xand this one}
X
Xtest open-9.1 {seek command} {
X list [catch {seek foo} msg] $msg $errorCode
X} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE}
Xtest open-9.2 {seek command} {
X list [catch {seek foo a b c} msg] $msg $errorCode
X} {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE}
Xtest open-9.3 {seek command} {
X list [catch {seek foo 0} msg] $msg $errorCode
X} {1 {bad file identifier "foo"} NONE}
Xtest open-9.4 {seek command} {
X set f [open test2]
X set x [list [catch {seek $f xyz} msg] $msg $errorCode]
X close $f
X set x
X} {1 {expected integer but got "xyz"} NONE}
Xtest open-9.5 {seek command} {
X set f [open test2]
X set x [list [catch {seek $f 100 gorp} msg] $msg $errorCode]
X close $f
X set x
X} {1 {bad origin "gorp": should be start, current, or end} NONE}
Xset f [open test3 w]
Xputs $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" nonewline
Xclose $f
Xtest open-9.6 {seek command} {
X set f [open test3]
X set x [read $f 1]
X seek $f 3
X lappend x [read $f 1]
X seek $f 0 start
X lappend x [read $f 1]
X seek $f 10 current
X lappend x [read $f 1]
X seek $f -2 end
X lappend x [read $f 1]
X seek $f 50 end
X lappend x [read $f 1]
X seek $f 1
X lappend x [read $f 1]
X close $f
X set x
X} {a d a l Y {} b}
X
Xtest open-10.1 {tell command} {
X list [catch {tell} msg] $msg $errorCode
X} {1 {wrong # args: should be "tell fileId"} NONE}
Xtest open-10.2 {tell command} {
X list [catch {tell a b} msg] $msg $errorCode
X} {1 {wrong # args: should be "tell fileId"} NONE}
Xtest open-10.3 {tell command} {
X list [catch {tell a} msg] $msg $errorCode
X} {1 {bad file identifier "a"} NONE}
Xtest open-10.4 {tell command} {
X set f [open test2]
X set x [tell $f]
X read $f 3
X lappend x [tell $f]
X seek $f 2
X lappend x [tell $f]
X seek $f 10 current
X lappend x [tell $f]
X seek $f 0 end
X lappend x [tell $f]
X close $f
X set x
X} {0 3 2 12 30}
X
Xtest open-11.1 {eof command} {
X list [catch {eof} msg] $msg $errorCode
X} {1 {wrong # args: should be "eof fileId"} NONE}
Xtest open-11.2 {eof command} {
X list [catch {eof a b} msg] $msg $errorCode
X} {1 {wrong # args: should be "eof fileId"} NONE}
Xtest open-11.3 {eof command} {
X list [catch {eof file100} msg] $msg $errorCode
X} {1 {file "file100" isn't open} NONE}
Xtest open-11.4 {eof command} {
X set f [open test1]
X set x [eof $f]
X lappend x [eof $f]
X gets $f
X lappend x [eof $f]
X gets $f
X lappend x [eof $f]
X gets $f
X lappend x [eof $f]
X lappend x [eof $f]
X close $f
X set x
X} {0 0 0 0 1 1}
X
Xtest open-12.1 {flush command} {
X list [catch {flush} msg] $msg $errorCode
X} {1 {wrong # args: should be "flush fileId"} NONE}
Xtest open-12.2 {flush command} {
X list [catch {flush a b} msg] $msg $errorCode
X} {1 {wrong # args: should be "flush fileId"} NONE}
Xtest open-12.3 {flush command} {
X list [catch {flush a} msg] $msg $errorCode
X} {1 {bad file identifier "a"} NONE}
Xtest open-12.4 {flush command} {
X set f [open test3]
X set x [list [catch {flush $f} msg] \
X [string range $msg [string first " " $msg] end] $errorCode]
X close $f
X set x
X} {1 { wasn't opened for writing} NONE}
Xtest open-12.5 {flush command} {
X set f [open test3 w]
X puts $f "Line 1"
X puts $f "Line 2"
X set f2 [open test3]
X set x {}
X lappend x [read $f2 nonewline]
X close $f2
X flush $f
X set f2 [open test3]
X lappend x [read $f2 nonewline]
X close $f2
X close $f
X set x
X} {{} {Line 1
XLine 2}}
X
Xtest open-13.1 {I/O to command pipelines} {
X list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode
X} {1 {can't write input to command: standard input was redirected} NONE}
Xtest open-13.2 {I/O to command pipelines} {
X list [catch {open "| echo > test3" r} msg] $msg $errorCode
X} {1 {can't read output from command: standard output was redirected} NONE}
Xtest open-13.3 {I/O to command pipelines} {
X list [catch {open "| echo > test3" r+} msg] $msg $errorCode
X} {1 {can't read output from command: standard output was redirected} NONE}
Xtest open-13.4 {writing to command pipelines} {
X exec rm test3
X set f [open "| cat | cat > test3" w]
X puts $f "Line 1"
X puts $f "Line 2"
X close $f
X exec cat test3
X} {Line 1
XLine 2}
Xtest open-13.5 {reading from command pipelines} {
X set f [open "| cat test2" r]
X set x [list [gets $f] [gets $f] [gets $f]]
X close $f
X set x
X} {line1 line2 line3}
Xtest open-13.6 {both reading and writing from/to command pipelines} {
X set f [open "| cat" r+]
X puts $f "Line1"
X flush $f
X set x [gets $f]
X close $f
X set x
X} {Line1}
Xtest open-13.7 {errors in command pipelines} {
X set f [open "|gorp"]
X list [catch {close $f} msg] $msg [lindex $errorCode 0] [lindex $errorCode 2]

X} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1}

Xtest open-13.8 {errors in command pipelines} {
X set f [open "|gorp" w]
X exec sleep 1
X puts $f output
X set x [list [catch {flush $f} msg] [concat \
X [string range $msg 0 [string first {"} $msg]] \
X [string range $msg [string first : $msg] end]] $errorCode]
X catch {close $f}
X string tolower $x
X} {1 {error flushing " : broken pipe} {unix epipe {broken pipe}}}
Xtest open-13.9 {errors in command pipelines} {
X set f [open "|gorp" w]
X list [catch {close $f} msg] $msg \
X [lindex $errorCode 0] [lindex $errorCode 2]

X} {1 {couldn't find "gorp" to execute} CHILDSTATUS 1}

Xtest open-13.10 {errors in command pipelines} {
X set f [open "|gorp" w]
X exec sleep 1
X puts $f output
X string tolower [list [catch {close $f} msg] [concat \
X [string range $msg 0 [string first {"} $msg]] \
X [string range $msg [string first : $msg] end]] \
X [lindex $errorCode 0] [lindex $errorCode 2]]
X} {1 {error closing " : broken pipe
Xcouldn't find "gorp" to execute} childstatus 1}
X
Xcatch {exec rm -f test1 test2 test3}
Xconcat {}
END_OF_FILE
if test 16158 -ne `wc -c <'tcl6.1/tests/open.test'`; then
echo shar: \"'tcl6.1/tests/open.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/open.test'
fi
if test -f 'tcl6.1/tests/set.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/set.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/set.test'\" $16970 characters$
sed "s/^X//" >'tcl6.1/tests/set.test' <<'END_OF_FILE'
X# Commands covered: set, unset, array

X# $Header: /user6/ouster/tcl/tests/RCS/set.test,v 1.8 91/10/31 16:40:57 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc ignore args {}
X
X# Simple variable operations.
X
Xcatch {unset a}
Xtest set-1.1 {basic variable setting and unsetting} {
X set a 22
X} 22
Xtest set-1.2 {basic variable setting and unsetting} {
X set a 123
X set a
X} 123
Xtest set-1.3 {basic variable setting and unsetting} {
X set a xxx
X format %s $a
X} xxx
Xtest set-1.4 {basic variable setting and unsetting} {
X set a 44
X unset a
X list [catch {set a} msg] $msg
X} {1 {can't read "a": no such variable}}
X
X# Basic array operations.
X
Xcatch {unset a}
Xset a(xyz) 2
Xset a(44) 3
Xset {a(a long name)} test
Xtest set-2.1 {basic array operations} {
X lsort [array names a]
X} {44 {a long name} xyz}
Xtest set-2.2 {basic array operations} {
X set a(44)
X} 3
Xtest set-2.3 {basic array operations} {
X set a(xyz)
X} 2
Xtest set-2.4 {basic array operations} {
X set "a(a long name)"
X} test
Xtest set-2.5 {basic array operations} {
X list [catch {set a(other)} msg] $msg
X} {1 {can't read "a(other)": no such element in array}}
Xtest set-2.6 {basic array operations} {
X list [catch {set a} msg] $msg
X} {1 {can't read "a": no such variable}}
Xtest set-2.7 {basic array operations} {
X format %s $a(44)
X} 3
Xtest set-2.8 {basic array operations} {
X format %s $a(a long name)
X} test
Xunset a(44)
Xtest set-2.9 {basic array operations} {
X lsort [array names a]
X} {{a long name} xyz}
Xunset a
Xtest set-2.10 {basic array operations} {
X list [catch {set a(xyz)} msg] $msg
X} {1 {can't read "a(xyz)": no such variable}}
X
X# Test the set commands, and exercise the corner cases of the code
X# that parses array references into two parts.
X
Xtest set-3.1 {set command} {
X list [catch {set} msg] $msg
X} {1 {wrong # args: should be "set varName ?newValue?"}}
Xtest set-3.2 {set command} {
X list [catch {set x y z} msg] $msg
X} {1 {wrong # args: should be "set varName ?newValue?"}}
Xtest set-3.3 {set command} {
X catch {unset a}
X list [catch {set a} msg] $msg
X} {1 {can't read "a": no such variable}}
Xtest set-3.4 {set command} {
X catch {unset a}
X set a(14) 83
X list [catch {set a 22} msg] $msg
X} {1 {can't set "a": variable is array}}
X
X# Test the corner-cases of parsing array names, using set and unset.
X
Xtest set-4.1 {parsing array names} {
X catch {unset a}
X set a(()) 44

X list [catch {array names a} msg] $msg

X} {0 ()}
Xtest set-4.2 {parsing array names} {
X catch {unset a a(abcd}
X set a(abcd 33
X info exists a(abcd
X} 1
Xtest set-4.3 {parsing array names} {
X catch {unset a a(abcd}
X set a(abcd 33
X list [catch {array names a} msg] $msg
X} {1 {"a" isn't an array}}
Xtest set-4.4 {parsing array names} {
X catch {unset a abcd)}
X set abcd) 33
X info exists abcd)
X} 1
Xtest set-4.5 {parsing array names} {
X set a(bcd yyy
X catch {unset a}
X list [catch {set a(bcd} msg] $msg
X} {0 yyy}
Xtest set-4.6 {parsing array names} {
X catch {unset a}
X set a 44
X list [catch {set a(bcd test} msg] $msg
X} {0 test}
X
X# Errors in reading variables
X
Xtest set-5.1 {errors in reading variables} {
X catch {unset a}
X list [catch {set a} msg] $msg
X} {1 {can't read "a": no such variable}}
Xtest set-5.2 {errors in reading variables} {
X catch {unset a}
X set a 44
X list [catch {set a(18)} msg] $msg
X} {1 {can't read "a(18)": variable isn't array}}
Xtest set-5.3 {errors in reading variables} {
X catch {unset a}
X set a(6) 44
X list [catch {set a(18)} msg] $msg
X} {1 {can't read "a(18)": no such element in array}}
Xtest set-5.4 {errors in reading variables} {
X catch {unset a}
X set a(6) 44
X list [catch {set a} msg] $msg
X} {1 {can't read "a": no such variable}}
X
X# Errors and other special cases in writing variables
X
Xtest set-6.1 {creating array during write} {
X catch {unset a}
X trace var a rwu ignore
X list [catch {set a(14) 186} msg] $msg [array names a]
X} {0 186 14}
Xtest set-6.2 {errors in writing variables} {
X catch {unset a}
X set a xxx
X list [catch {set a(14) 186} msg] $msg
X} {1 {can't set "a(14)": variable isn't array}}
Xtest set-6.3 {errors in writing variables} {
X catch {unset a}
X set a(100) yyy
X list [catch {set a 2} msg] $msg
X} {1 {can't set "a": variable is array}}
Xtest set-6.4 {expanding variable size} {
X catch {unset a}
X list [set a short] [set a "longer name"] [set a "even longer name"] \
X [set a "a much much truly longer name"]
X} {short {longer name} {even longer name} {a much much truly longer name}}
X
X# Unset command, Tcl_UnsetVar procedures
X
Xtest set-7.1 {unset command} {
X catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d}
X set a 44
X set b 55
X set c 66
X set d 77
X unset a b c
X list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \
X [catch {set d(0) 0}]
X} {0 0 0 1}
Xtest set-7.2 {unset command} {
X list [catch {unset} msg] $msg
X} {1 {wrong # args: should be "unset varName ?varName ...?"}}
Xtest set-7.3 {unset command} {
X catch {unset a}
X list [catch {unset a} msg] $msg
X} {1 {can't unset "a": no such variable}}
Xtest set-7.4 {unset command} {
X catch {unset a}
X set a 44
X list [catch {unset a(14)} msg] $msg
X} {1 {can't unset "a(14)": variable isn't array}}
Xtest set-7.5 {unset command} {
X catch {unset a}
X set a(0) xx
X list [catch {unset a(14)} msg] $msg
X} {1 {can't unset "a(14)": no such element in array}}
Xtest set-7.6 {unset command} {
X catch {unset a}; catch {unset b}; catch {unset c}
X set a foo
X set c gorp
X list [catch {unset a a a(14)} msg] $msg [info exists c]
X} {1 {can't unset "a": no such variable} 1}
Xtest set-7.7 {unsetting globals from within procedures} {
X set y 0
X proc p1 {} {
X global y
X set z [p2]
X return [list $z [catch {set y} msg] $msg]
X }
X proc p2 {} {global y; unset y; list [catch {set y} msg] $msg}
X p1
X} {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}}
Xtest set-7.8 {unsetting globals from within procedures} {
X set y 0
X proc p1 {} {
X global y
X p2
X return [list [catch {set y 44} msg] $msg]
X }
X proc p2 {} {global y; unset y}
X concat [p1] [list [catch {set y} msg] $msg]
X} {0 44 0 44}
Xtest set-7.9 {unsetting globals from within procedures} {
X set y 0
X proc p1 {} {
X global y
X unset y
X return [list [catch {set y 55} msg] $msg]
X }
X concat [p1] [list [catch {set y} msg] $msg]
X} {0 55 0 55}
Xtest set-7.10 {unset command} {
X catch {unset a}
X set a(14) 22
X unset a(14)
X list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
X} {1 {can't read "a(14)": no such element in array} 0 {}}
Xtest set-7.11 {unset command} {
X catch {unset a}
X set a(14) 22
X unset a
X list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
X} {1 {can't read "a(14)": no such variable} 1 {"a" isn't an array}}
X
X# Array command.
X
Xtest set-8.1 {array command} {
X list [catch {array} msg] $msg
X} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
Xtest set-8.2 {array command} {
X catch {unset a}
X list [catch {array names a} msg] $msg
X} {1 {"a" isn't an array}}
Xtest set-8.3 {array command} {
X catch {unset a}
X set a 44
X list [catch {array names a} msg] $msg
X} {1 {"a" isn't an array}}
Xtest set-8.4 {array command} {
X catch {unset a}
X set a(22) 3
X list [catch {array gorp a} msg] $msg
X} {1 {bad option "gorp": should be anymore, donesearch, names, nextelement, size, or startsearch}}
Xtest set-8.5 {array command, names option} {
X catch {unset a}
X set a(22) 3
X list [catch {array names a 4} msg] $msg
X} {1 {wrong # args: should be "array names arrayName"}}
Xtest set-8.6 {array command, names option} {
X catch {unset a}
X set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
X list [catch {lsort [array names a]} msg] $msg
X} {0 {22 Textual_name {name with spaces}}}
Xtest set-8.7 {array command, names option} {
X catch {unset a}
X set a(22) 3; set a(33) 44;
X trace var a(xxx) w ignore
X list [catch {lsort [array names a]} msg] $msg
X} {0 {22 33}}
Xtest set-8.8 {array command, names option} {
X catch {unset a}
X set a(22) 3; set a(33) 44;
X trace var a(xxx) w ignore
X set a(xxx) value
X list [catch {lsort [array names a]} msg] $msg
X} {0 {22 33 xxx}}
Xtest set-8.9 {array command, size option} {
X catch {unset a}
X set a(22) 3
X list [catch {array size a 4} msg] $msg
X} {1 {wrong # args: should be "array size arrayName"}}
Xtest set-8.10 {array command, size option} {
X catch {unset a}
X set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
X list [catch {array size a} msg] $msg
X} {0 3}
Xtest set-8.10 {array command, size option} {
X catch {unset a}
X set a(22) 3; set a(xx) 44; set a(y) xxx
X unset a(22) a(y) a(xx)
X list [catch {array size a} msg] $msg
X} {0 0}
Xtest set-8.11 {array command, size option} {
X catch {unset a}
X set a(22) 3;
X trace var a(33) rwu ignore
X list [catch {array size a} msg] $msg
X} {0 1}
X
Xtest set-9.1 {ids for array enumeration} {
X catch {unset a}
X set a(a) 1
X list [array st a] [array st a] [array done a s-1-a; array st a] \
X [array done a s-2-a; array d a s-3-a; array start a]
X} {s-1-a s-2-a s-3-a s-1-a}
Xtest set-9.2 {array enumeration} {
X catch {unset a}
X set a(a) 1
X set a(b) 1
X set a(c) 1
X set x [array startsearch a]
X list [array nextelement a $x] [array ne a $x] [array next a $x] \
X [array next a $x] [array next a $x]
X} {a b c {} {}}
Xtest set-9.3 {array enumeration} {
X catch {unset a}
X set a(a) 1
X set a(b) 1
X set a(c) 1
X set x [array startsearch a]
X set y [array startsearch a]
X set z [array startsearch a]
X list [array nextelement a $x] [array ne a $x] \
X [array next a $y] [array next a $z] [array next a $y] \
X [array next a $z] [array next a $y] [array next a $z] \
X [array next a $y] [array next a $z] [array next a $x] \
X [array next a $x]
X} {a b a a b b c c {} {} c {}}
Xtest set-9.4 {array enumeration: stopping searches} {
X catch {unset a}
X set a(a) 1
X set a(b) 1
X set a(c) 1
X set x [array startsearch a]
X set y [array startsearch a]
X set z [array startsearch a]
X list [array next a $x] [array next a $x] [array next a $y] \
X [array done a $z; array next a $x] \
X [array done a $x; array next a $y] [array next a $y]
X} {a b a c b c}
Xtest set-9.5 {array enumeration: stopping searches} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X array done a $x
X list [catch {array next a $x} msg] $msg
X} {1 {couldn't find search "s-1-a"}}
Xtest set-9.6 {array enumeration: searches automatically stopped} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X set y [array startsearch a]
X set a(b) 1
X list [catch {array next a $x} msg] $msg \
X [catch {array next a $y} msg2] $msg2
X} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
Xtest set-9.7 {array enumeration: searches automatically stopped} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X set y [array startsearch a]
X set a(a) 2
X list [catch {array next a $x} msg] $msg \
X [catch {array next a $y} msg2] $msg2
X} {0 a 0 a}
Xtest set-9.8 {array enumeration: searches automatically stopped} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X set y [array startsearch a]
X catch {unset a(c)}
X list [catch {array next a $x} msg] $msg \
X [catch {array next a $y} msg2] $msg2
X} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
Xtest set-9.9 {array enumeration: searches automatically stopped} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X set y [array startsearch a]
X trace var a(b) r {}
X list [catch {array next a $x} msg] $msg \
X [catch {array next a $y} msg2] $msg2
X} {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}}
Xtest set-9.10 {array enumeration: searches automatically stopped} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X set y [array startsearch a]
X trace var a(a) r {}
X list [catch {array next a $x} msg] $msg \
X [catch {array next a $y} msg2] $msg2
X} {0 a 0 a}
Xtest set-9.11 {array enumeration with traced undefined elements} {
X catch {unset a}
X set a(a) 1
X trace var a(b) r {}
X set x [array startsearch a]
X list [array next a $x] [array next a $x]
X} {a {}}
X
Xtest set-10.1 {array enumeration errors} {
X list [catch {array start} msg] $msg
X} {1 {wrong # args: should be "array option arrayName ?arg ...?"}}
Xtest set-10.2 {array enumeration errors} {
X list [catch {array start a b} msg] $msg
X} {1 {wrong # args: should be "array startsearch arrayName"}}
Xtest set-10.3 {array enumeration errors} {
X catch {unset a}
X list [catch {array start a} msg] $msg
X} {1 {"a" isn't an array}}
Xtest set-10.4 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a} msg] $msg
X} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
Xtest set-10.5 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a b c} msg] $msg
X} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
Xtest set-10.6 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a a-1-a} msg] $msg
X} {1 {illegal search identifier "a-1-a"}}
Xtest set-10.7 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a sx1-a} msg] $msg
X} {1 {illegal search identifier "sx1-a"}}
Xtest set-10.8 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a s--a} msg] $msg
X} {1 {illegal search identifier "s--a"}}
Xtest set-10.9 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a s-1-b} msg] $msg
X} {1 {search identifier "s-1-b" isn't for variable "a"}}
Xtest set-10.10 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a s-1ba} msg] $msg
X} {1 {illegal search identifier "s-1ba"}}
Xtest set-10.11 {array enumeration errors} {
X catch {unset a}
X set a(a) 1
X set x [array startsearch a]
X list [catch {array next a s-2-a} msg] $msg
X} {1 {couldn't find search "s-2-a"}}
Xtest set-10.12 {array enumeration errors} {
X list [catch {array done a} msg] $msg
X} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
Xtest set-10.13 {array enumeration errors} {
X list [catch {array done a b c} msg] $msg
X} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
Xtest set-10.14 {array enumeration errors} {
X list [catch {array done a b} msg] $msg
X} {1 {illegal search identifier "b"}}
Xtest set-10.15 {array enumeration errors} {
X list [catch {array anymore a} msg] $msg
X} {1 {wrong # args: should be "array anymore arrayName searchId"}}
Xtest set-10.16 {array enumeration errors} {
X list [catch {array any a b c} msg] $msg
X} {1 {wrong # args: should be "array anymore arrayName searchId"}}
Xtest set-10.17 {array enumeration errors} {
X catch {unset a}
X set a(0) 44
X list [catch {array any a bogus} msg] $msg
X} {1 {illegal search identifier "bogus"}}
X
X# Array enumeration with "anymore" option
X
Xtest set-11.1 {array anymore option} {
X catch {unset a}
X set a(a) 1
X set a(b) 2
X set a(c) 3
X array startsearch a
X list [array anymore a s-1-a] [array next a s-1-a] \
X [array anymore a s-1-a] [array next a s-1-a] \
X [array anymore a s-1-a] [array next a s-1-a] \
X [array anymore a s-1-a] [array next a s-1-a]
X} {1 a 1 b 1 c 0 {}}
Xtest set-11.2 {array anymore option} {
X catch {unset a}
X set a(a) 1
X set a(b) 2
X set a(c) 3
X array startsearch a
X list [array next a s-1-a] [array next a s-1-a] \
X [array anymore a s-1-a] [array next a s-1-a] \
X [array next a s-1-a] [array anymore a s-1-a]
X} {a b 1 c {} 0}
X
X# Must delete variables when done, since these arrays get used as
X# scalars by other tests.
X
Xcatch {unset a}
Xcatch {unset b}
Xcatch {unset c}
Xreturn ""
END_OF_FILE
if test 16970 -ne `wc -c <'tcl6.1/tests/set.test'`; then
echo shar: \"'tcl6.1/tests/set.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/set.test'
fi
echo shar: End of archive 13 $of 33$.
cp /dev/null ark13isdone

Karl Lehenbauer

unread,

Nov 14, 1991, 3:31:38 PM11/14/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 82
Archive-name: tcl/part14
Environment: UNIX

# "End of archive 14 (of 33)."
# Contents: tcl6.1/doc/TraceVar.man tcl6.1/tests/expr.test
# Wrapped by karl@one on Tue Nov 12 19:44:22 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/TraceVar.man' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/TraceVar.man'\"
else
echo shar: Extracting \"'tcl6.1/doc/TraceVar.man'\" $17059 characters$
sed "s/^X//" >'tcl6.1/doc/TraceVar.man' <<'END_OF_FILE'

X'\" the suitability of this material for any purpose. It is
X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/TraceVar.man,v 1.6 91/08/27 13:46:37 ouster Exp $ SPRITE (Berkeley)

X.HS Tcl_TraceVar tcl
X.VS
X.BS
X.SH NAME
XTcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, \
XTcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable
X.SH SYNOPSIS
X.nf

X\fB#include <tcl.h>\fR
X.sp
Xint

X\fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR
X.sp
Xint
X\fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR
X.sp
X\fBTcl_UnTraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR
X.sp
X\fBTcl_UnTraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR
X.sp
XClientData
X\fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR
X.sp
XClientData
X\fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR
X.SH ARGUMENTS
X.AS Tcl_VarTraceProc prevClientData

X.AP Tcl_Interp *interp in
XInterpreter containing variable.
X.AP char *varName in

XName of variable. May refer to a scalar variable, to
Xan array variable with no index, or to an array variable
Xwith a parenthesized index.
X.AP int flags in
XOR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and
XTCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. Not all flags are used by all
Xprocedures. See below for more information.
X.AP Tcl_VarTraceProc *proc in
XProcedure to invoke whenever one of the traced operations occurs.

X.AP ClientData clientData in
XArbitrary one-word value to pass to \fIproc\fR.

X.AP char *name1 in
XName of scalar or array variable (without array index).
X.AP char *name2 in
XFor a trace on an element of an array, gives the index of the
Xelement. For traces on scalar variables or on whole arrays,
Xis NULL.
X.AP ClientData prevClientData in
XIf non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or
X\fBTcl_VarTraceInfo2\fR, so this call will return information about
Xnext trace. If NULL, this call will return information about first
Xtrace.

X.BE
X
X.SH DESCRIPTION
X.PP

X\fBTcl_TraceVar\fR allows a C procedure to monitor and control
Xaccess to a Tcl variable, so that the C procedure is invoked
Xwhenever the variable is read or written or unset.
XIf the trace is created successfully then \fBTcl_TraceVar\fR returns
XTCL_OK. If an error occurred (e.g. \fIvarName\fR specifies an element
Xof an array, but the actual variable isn't an array) then TCL_ERROR
Xis returned and an error message is left in \fIinterp->result\fR.
X.PP
XThe \fIflags\fR argument to \fBTcl_TraceVar\fR indicates when the
Xtrace procedure is to be invoked and provides information
Xfor setting up the trace. It consists of an OR-ed combination
Xof any of the following values:
X.TP
X\fBTCL_GLOBAL_ONLY\fR
XNormally, the variable will be looked up at the current level of
Xprocedure call; if this bit is set then the variable will be looked
Xup at global level, ignoring any active procedures.
X.TP
X\fBTCL_TRACE_READS\fR
XInvoke \fIproc\fR whenever an attempt is made to read the variable.
X.TP
X\fBTCL_TRACE_WRITES\fR
XInvoke \fIproc\fR whenever an attempt is made to modify the variable.
X.TP
X\fBTCL_TRACE_UNSETS\fR
XInvoke \fIproc\fR whenever the variable is unset.
XA variable may be unset either explicitly by an \fBunset\fR command,
Xor implicitly when a procedure returns (its local variables are
Xautomatically unset) or when the interpreter is deleted (all
Xvariables are automatically unset).
X.PP
XWhenever one of the specified operations occurs on the variable,
X\fIproc\fR will be invoked.
XIt should have arguments and result that match the type
X\fBTcl_VarTraceProc\fR:
X.nf
X.RS
Xtypedef char *Tcl_VarTraceProc(

X.RS
XClientData \fIclientData\fR,
XTcl_Interp *\fIinterp\fR,

Xchar *\fIname1\fR,
Xchar *\fIname2\fR,
Xint \fIflags\fR);
X.RE
X.RE
X.fi
XThe \fIclientData\fP and \fIinterp\fP parameters will
Xhave the same values as those passed to \fBTcl_TraceVar\fR when the
Xtrace was created.

X\fIClientData\fR typically points to an application-specific
Xdata structure that describes what to do when \fIproc\fR
Xis invoked.

X\fIName1\fR and \fIname2\fR give the name of the traced variable
Xin the normal two-part form (see the description of \fBTcl_TraceVar2\fR
Xbelow for details).
X\fIFlags\fR is an OR-ed combination of bits providing several
Xpieces of information.
XOne of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, or TCL_TRACE_UNSETS
Xwill be set in \fIflags\fR to indicate which operation is being performed
Xon the variable.
XThe bit TCL_GLOBAL_ONLY will be set whenever the variable being
Xaccessed is a global one not accessible from the current level of
Xprocedure call: the trace procedure will need to pass this flag
Xback to variable-related procedures like \fBTcl_GetVar\fR if it
Xattempts to access the variable.
XThe bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is
Xabout to be destroyed; this information may be useful to \fIproc\fR
Xso that it can clean up its own internal data structures (see
Xthe section TCL_TRACE_DESTROYED below for more details).
XLastly, the bit TCL_INTERP_DESTROYED will be set if the entire
Xinterpreter is being destroyed.
XWhen this bit is set, \fIproc\fR must be especially careful in
Xthe things it does (see the section TCL_INTERP_DESTROYED below).
XThe trace procedure's return value should normally be NULL; see
XERROR RETURNS below for information on other possibilities.
X.PP
X\fBTcl_UnsetTrace\fR may be used to remove a trace.
XIf the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR
Xhas a trace set with \fIflags\fR, \fIproc\fR, and
X\fIclientData\fR, then the corresponding trace is removed.
XIf no such trace exists, then the call to \fBTcl_UnsetTrace\fR
Xhas no effect.
XThe same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVars\fR.
X.PP
X\fBTcl_VarTraceInfo\fR may be used to retrieve information about
Xtraces set on a given variable.
XThe return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR
Xassociated with a particular trace.
XThe trace must be on the variable specified by the \fIinterp\fR,
X\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY
Xbit from \fIflags\fR is used; other bits are ignored) and its trace procedure
Xmust the same as the \fIproc\fR argument.
XIf the \fIprevClientData\fR argument is NULL then the return
Xvalue corresponds to the first (most recently created) matching
Xtrace, or NULL if there are no matching traces.
XIf the \fIprevClientData\fR argument isn't NULL, then it should
Xbe the return value from a previous call to \fBTcl_VarTraceInfo\fR.
XIn this case, the new return value will correspond to the next
Xmatching trace after the one whose \fIclientData\fR matches
X\fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR
Xor if there are no more matching traces after it.
XThis mechanism makes it possible to step through all of the
Xtraces for a given variable that have the same \fIproc\fR.
X
X.SH "TWO-PART NAMES"
X.PP
XThe procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and
X\fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR,
X\fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively,
Xexcept that the name of the variable has already been
Xseparated by the caller into two parts.
X\fIName1\fR gives the name of a scalar variable or array,
Xand \fIname2\fR gives the name of an element within an
Xarray.
XIf \fIname2\fR is NULL it means that either the variable is
Xa scalar or the trace is to be set on the entire array rather
Xthan an individual element (see WHOLE-ARRAY TRACES below for
Xmore information).
X
X.SH "ACCESSING VARIABLES DURING TRACES"
X.PP
XDuring read and write traces, the
Xtrace procedure can read or write the value of the traced
Xvariable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and
Xother procedures.
XWhile \fIproc\fR is executing, traces are temporarily disabled
Xfor the variable, so that calls to \fBTcl_GetVar2\fR and
X\fBTcl_SetVar2\fR will not cause \fIproc\fR or other trace procedures
Xto be invoked again.
XDisabling only occurs for the variable whose trace procedure
Xis active; accesses to other variables will still be traced.
X.PP
XDuring unset traces the variable has already been completely
Xexpunged.
XIt is possible for the trace procedure to read or write the
Xvariable, but this will be a new version of the variable.
XTraces are not disabled during unset traces as they are for
Xread and write traces, but existing traces have been removed
Xfrom the variable before any trace procedures are invoked.
XIf new traces are set by unset trace procedures, these traces
Xwill be invoked on accesses to the variable by the trace
Xprocedures.
X
X.SH "CALLBACK TIMING"
X.PP
XWhen read tracing has been specified for a variable, the trace
Xprocedure will be invoked whenever the variable's value is
Xread. This includes \fBset\fR Tcl commands, \fB$\fR-notation
Xin Tcl commands, and invocations of the \fBTcl_GetVar\fR
Xand \fBTcl_GetVar2\fR procedures.
X\fIProc\fR is invoked just before the variable's value is
Xreturned.
XIt may modify the value of the variable to affect what
Xis returned by the traced access.
X.PP
XWhen write tracing has been specified for a variable, the
Xtrace procedure will be invoked whenever the variable's value
Xis modified. This includes \fBset\fR commands\fR,
Xcommands that modify variables as side effects (such as
X\fBcatch\fR and \fBscan\fR), and calls to the \fBTcl_SetVar\fR
Xand \fBTcl_SetVar2\fR procedures).
X\fIProc\fR will be invoked after the variable's value has been
Xmodified, but before the new value of the variable has been
Xreturned.
XIt may modify the value of the variable to override the change
Xand to determine the value actually returned by the traced
Xaccess.
X.PP
XWhen unset tracing has been specified, the trace procedure
Xwill be invoked whenever the variable is destroyed.
XThe traces will be called after the variable has been
Xcompletely unset.
X
X.SH "WHOLE-ARRAY TRACES"
X.PP
XIf a call to \fBTcl_TraceVar\fR or \fBTcl_TraceVar2\fR specifies
Xthe name of an array variable without an index into the array,
Xthen the trace will be set on the array as a whole.
XThis means that \fIproc\fR will be invoked whenever any
Xelement of the array is accessed in the ways specified by
X\fIflags\fR.
XWhen an array is unset, a whole-array trace will be invoked
Xjust once, with \fIname1\fR equal to the name of the array
Xand \fIname2\fR NULL; it will not be invoked once for each
Xelement.
X
X.SH "MULTIPLE TRACES"
X.PP
XIt is possible for multiple traces to exist on the same variable.
XWhen this happens, all of the trace procedures will be invoked on each
Xaccess, in order from most-recently-created to least-recently-created.
XWhen there exist whole-array traces for an array as well as
Xtraces on individual elements, the whole-array traces are invoked
Xbefore the individual-element traces.
X
X.SH "ERROR RETURNS"
X.PP
XUnder normal conditions trace procedures should return NULL, indicating
Xsuccessful completion.
XIf \fIproc\fR returns a non-NULL value it signifies that an
Xerror occurred.
XThe return value must be a pointer to a static character string
Xcontaining an error message.
XIf a trace procedure returns an error, no further traces are
Xinvoked for the access and the traced access aborts with the
Xgiven message.
XTrace procedures can use this facility to make variables
Xread-only, for example (but note that the value of the variable
Xwill already have been modified before the trace procedure is
Xcalled, so the trace procedure will have to restore the correct
Xvalue).
X.PP
XThe return value from \fIproc\fR is only used during read and
Xwrite tracing.
XDuring unset traces, the return value is ignored and all relevant
Xtrace procedures will always be invoked.
X
X.SH "RESTRICTIONS"
X.PP
XIt is not legal to delete a variable while a trace procedure
Xis active for the variable.
X
X.SH "UNDEFINED VARIABLES"
X.PP
XIt is legal to set a trace on an undefined variable.
XThe variable will still appear to be undefined until the
Xfirst time its value is set.
XIf an undefined variable is traced and then unset, the unset will fail
Xwith an error (``no such variable''), but the trace
Xprocedure will still be invoked.
X
X.SH "TCL_TRACE_DELETED FLAG"
X.PP
XIn an unset callback to \fIproc\fR, the TCL_TRACE_DELETED bit
Xis set in \fIflags\fR if the trace is being removed as part
Xof the deletion.
XTraces on a variable are always removed whenever the variable
Xis deleted; the only time TCL_TRACE_DELETED isn't set is for
Xa whole-array trace invoked when only a single element of an
Xarray is unset.
X
X.SH "TCL_INTERP_DESTROYED"
X.PP
XWhen an interpreter is destroyed, unset traces are called for
Xall of its variables.
XThe TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR
Xargument passed to the trace procedures.
XTrace procedures must be extremely careful in what they do if
Xthe TCL_INTERP_DESTROYED bit is set.
XIt is not safe for the procedures to invoke any Tcl procedures
Xon the interpreter, since its state is partially deleted.
XAll that trace procedures should do under these circumstances is
Xto clean up and free their own internal data structures.
X
X.SH BUGS
X.PP
XTcl doesn't do any error checking to prevent trace procedures
Xfrom misusing the interpreter during traces with TCL_INTERP_DESTROYED
Xset.
X
X.SH KEYWORDS
XclientData, trace, variable
X.VE
END_OF_FILE
if test 17059 -ne `wc -c <'tcl6.1/doc/TraceVar.man'`; then
echo shar: \"'tcl6.1/doc/TraceVar.man'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/TraceVar.man'
fi
if test -f 'tcl6.1/tests/expr.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/expr.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/expr.test'\" $19899 characters$
sed "s/^X//" >'tcl6.1/tests/expr.test' <<'END_OF_FILE'
X# Commands covered: expr

X# $Header: /user6/ouster/tcl/tests/RCS/expr.test,v 1.11 91/10/31 16:40:46 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

X# First, test all of the integer operators individually.
X
Xtest expr-1.1 {integer operators} {expr -4} -4
Xtest expr-1.2 {integer operators} {expr -(1+4)} -5
Xtest expr-1.3 {integer operators} {expr ~3} -4
Xtest expr-1.4 {integer operators} {expr !2} 0
Xtest expr-1.5 {integer operators} {expr !0} 1
Xtest expr-1.6 {integer operators} {expr 4*6} 24
Xtest expr-1.7 {integer operators} {expr 36/12} 3
Xtest expr-1.8 {integer operators} {expr 27/4} 6
Xtest expr-1.9 {integer operators} {expr 27%4} 3
Xtest expr-1.10 {integer operators} {expr 2+2} 4
Xtest expr-1.11 {integer operators} {expr 2-6} -4
Xtest expr-1.12 {integer operators} {expr 1<<3} 8
Xtest expr-1.13 {integer operators} {expr 0xff>>2} 63
Xtest expr-1.14 {integer operators} {expr -1>>2} -1
Xtest expr-1.15 {integer operators} {expr 3>2} 1
Xtest expr-1.16 {integer operators} {expr 2>2} 0
Xtest expr-1.17 {integer operators} {expr 1>2} 0
Xtest expr-1.18 {integer operators} {expr 3<2} 0
Xtest expr-1.19 {integer operators} {expr 2<2} 0
Xtest expr-1.20 {integer operators} {expr 1<2} 1
Xtest expr-1.21 {integer operators} {expr 3>=2} 1
Xtest expr-1.22 {integer operators} {expr 2>=2} 1
Xtest expr-1.23 {integer operators} {expr 1>=2} 0
Xtest expr-1.24 {integer operators} {expr 3<=2} 0
Xtest expr-1.25 {integer operators} {expr 2<=2} 1
Xtest expr-1.26 {integer operators} {expr 1<=2} 1
Xtest expr-1.27 {integer operators} {expr 3==2} 0
Xtest expr-1.28 {integer operators} {expr 2==2} 1
Xtest expr-1.29 {integer operators} {expr 3!=2} 1
Xtest expr-1.30 {integer operators} {expr 2!=2} 0
Xtest expr-1.31 {integer operators} {expr 7&0x13} 3
Xtest expr-1.32 {integer operators} {expr 7^0x13} 20
Xtest expr-1.33 {integer operators} {expr 7|0x13} 23
Xtest expr-1.34 {integer operators} {expr 0&&1} 0
Xtest expr-1.35 {integer operators} {expr 0&&0} 0
Xtest expr-1.36 {integer operators} {expr 1&&3} 1
Xtest expr-1.37 {integer operators} {expr 0||1} 1
Xtest expr-1.38 {integer operators} {expr 3||0} 1
Xtest expr-1.39 {integer operators} {expr 0||0} 0
Xtest expr-1.40 {integer operators} {expr 3>2?44:66} 44
Xtest expr-1.41 {integer operators} {expr 2>3?44:66} 66
X
X# Check the floating-point operators individually, along with
X# automatic conversion to integers where needed.
X
Xtest expr-2.1 {floating-point operators} {expr -4.2} -4.2
Xtest expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3
Xtest expr-2.3 {floating-point operators} {expr !2.1} 0
Xtest expr-2.4 {floating-point operators} {expr !0.0} 1
Xtest expr-2.5 {floating-point operators} {expr 4.2*6.3} 26.46
Xtest expr-2.6 {floating-point operators} {expr 36.0/12.0} 3
Xtest expr-2.7 {floating-point operators} {expr 27/4.0} 6.75
Xtest expr-2.8 {floating-point operators} {expr 2.3+2.1} 4.4
Xtest expr-2.9 {floating-point operators} {expr 2.3-6.5} -4.2
Xtest expr-2.10 {floating-point operators} {expr 3.1>2.1} 1
Xtest expr-2.11 {floating-point operators} {expr {2.1 > 2.1}} 0
Xtest expr-2.12 {floating-point operators} {expr 1.23>2.34e+1} 0
Xtest expr-2.13 {floating-point operators} {expr 3.45<2.34} 0
Xtest expr-2.14 {floating-point operators} {expr 0.002e3<--200e-2} 0
Xtest expr-2.15 {floating-point operators} {expr 1.1<2.1} 1
Xtest expr-2.16 {floating-point operators} {expr 3.1>=2.2} 1
Xtest expr-2.17 {floating-point operators} {expr 2.345>=2.345} 1
Xtest expr-2.18 {floating-point operators} {expr 1.1>=2.2} 0
Xtest expr-2.19 {floating-point operators} {expr 3.0<=2.0} 0
Xtest expr-2.20 {floating-point operators} {expr 2.2<=2.2} 1
Xtest expr-2.21 {floating-point operators} {expr 2.2<=2.2001} 1
Xtest expr-2.22 {floating-point operators} {expr 3.2==2.2} 0
Xtest expr-2.23 {floating-point operators} {expr 2.2==2.2} 1
Xtest expr-2.24 {floating-point operators} {expr 3.2!=2.2} 1
Xtest expr-2.25 {floating-point operators} {expr 2.2!=2.2} 0
Xtest expr-2.26 {floating-point operators} {expr 0.0&&0.0} 0
Xtest expr-2.27 {floating-point operators} {expr 0.0&&1.3} 0
Xtest expr-2.28 {floating-point operators} {expr 1.3&&0.0} 0
Xtest expr-2.29 {floating-point operators} {expr 1.3&&3.3} 1
Xtest expr-2.30 {floating-point operators} {expr 0.0||0.0} 0
Xtest expr-2.31 {floating-point operators} {expr 0.0||1.3} 1
Xtest expr-2.32 {floating-point operators} {expr 1.3||0.0} 1
Xtest expr-2.33 {floating-point operators} {expr 3.3||0.0} 1
Xtest expr-2.34 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3
Xtest expr-2.35 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3
X
X# Operators that aren't legal on floating-point numbers
X
Xtest expr-3.1 {illegal floating-point operations} {
X list [catch {expr ~4.0} msg] $msg
X} {1 {can't use floating-point value as operand of "~"}}
Xtest expr-3.2 {illegal floating-point operations} {
X list [catch {expr 27%4.0} msg] $msg
X} {1 {can't use floating-point value as operand of "%"}}
Xtest expr-3.3 {illegal floating-point operations} {
X list [catch {expr 27.0%4} msg] $msg
X} {1 {can't use floating-point value as operand of "%"}}
Xtest expr-3.4 {illegal floating-point operations} {
X list [catch {expr 1.0<<3} msg] $msg
X} {1 {can't use floating-point value as operand of "<<"}}
Xtest expr-3.5 {illegal floating-point operations} {
X list [catch {expr 3<<1.0} msg] $msg
X} {1 {can't use floating-point value as operand of "<<"}}
Xtest expr-3.6 {illegal floating-point operations} {
X list [catch {expr 24.0>>3} msg] $msg
X} {1 {can't use floating-point value as operand of ">>"}}
Xtest expr-3.7 {illegal floating-point operations} {
X list [catch {expr 24>>3.0} msg] $msg
X} {1 {can't use floating-point value as operand of ">>"}}
Xtest expr-3.8 {illegal floating-point operations} {
X list [catch {expr 24&3.0} msg] $msg
X} {1 {can't use floating-point value as operand of "&"}}
Xtest expr-3.9 {illegal floating-point operations} {
X list [catch {expr 24.0|3} msg] $msg
X} {1 {can't use floating-point value as operand of "|"}}
Xtest expr-3.10 {illegal floating-point operations} {
X list [catch {expr 24.0^3} msg] $msg
X} {1 {can't use floating-point value as operand of "^"}}
X
X# Check the string operators individually.
X
Xtest expr-4.1 {string operators} {expr {"abc" > "def"}} 0
Xtest expr-4.2 {string operators} {expr {"def" > "def"}} 0
Xtest expr-4.3 {string operators} {expr {"g" > "def"}} 1
Xtest expr-4.4 {string operators} {expr {"abc" < "abd"}} 1
Xtest expr-4.5 {string operators} {expr {"abd" < "abd"}} 0
Xtest expr-4.6 {string operators} {expr {"abe" < "abd"}} 0
Xtest expr-4.7 {string operators} {expr {"abc" >= "def"}} 0
Xtest expr-4.8 {string operators} {expr {"def" >= "def"}} 1
Xtest expr-4.9 {string operators} {expr {"g" >= "def"}} 1
Xtest expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1
Xtest expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1
Xtest expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0
Xtest expr-4.13 {string operators} {expr {"abc" == "abd"}} 0
Xtest expr-4.14 {string operators} {expr {"abd" == "abd"}} 1
Xtest expr-4.15 {string operators} {expr {"abc" != "abd"}} 1
Xtest expr-4.16 {string operators} {expr {"abd" != "abd"}} 0
Xtest expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1
Xtest expr-4.18 {string operators} {expr {1?"foo":"bar"}} foo
Xtest expr-4.19 {string operators} {expr {0?"foo":"bar"}} bar
X
X# Operators that aren't legal on string operands.
X
Xtest expr-5.1 {illegal string operations} {
X list [catch {expr {-"a"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "-"}}
Xtest expr-5.2 {illegal string operations} {
X list [catch {expr {~"a"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "~"}}
Xtest expr-5.3 {illegal string operations} {
X list [catch {expr {!"a"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "!"}}
Xtest expr-5.4 {illegal string operations} {
X list [catch {expr {"a"*"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "*"}}
Xtest expr-5.5 {illegal string operations} {
X list [catch {expr {"a"/"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "/"}}
Xtest expr-5.6 {illegal string operations} {
X list [catch {expr {"a"%"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "%"}}
Xtest expr-5.7 {illegal string operations} {
X list [catch {expr {"a"+"b"}} msg] $msg

X} {1 {can't use non-numeric string as operand of "+"}}

Xtest expr-5.8 {illegal string operations} {
X list [catch {expr {"a"-"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "-"}}
Xtest expr-5.9 {illegal string operations} {
X list [catch {expr {"a"<<"b"}} msg] $msg

X} {1 {can't use non-numeric string as operand of "<<"}}

Xtest expr-5.10 {illegal string operations} {
X list [catch {expr {"a">>"b"}} msg] $msg

X} {1 {can't use non-numeric string as operand of ">>"}}

Xtest expr-5.11 {illegal string operations} {
X list [catch {expr {"a"&"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "&"}}
Xtest expr-5.12 {illegal string operations} {
X list [catch {expr {"a"^"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "^"}}
Xtest expr-5.13 {illegal string operations} {
X list [catch {expr {"a"|"b"}} msg] $msg

X} {1 {can't use non-numeric string as operand of "|"}}

Xtest expr-5.14 {illegal string operations} {
X list [catch {expr {"a"&&"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "&&"}}
Xtest expr-5.15 {illegal string operations} {
X list [catch {expr {"a"||"b"}} msg] $msg

X} {1 {can't use non-numeric string as operand of "||"}}

Xtest expr-5.16 {illegal string operations} {
X list [catch {expr {"a"?4:2}} msg] $msg
X} {1 {can't use non-numeric string as operand of "?"}}
X
X# Check precedence pairwise.
X
Xtest expr-6.1 {precedence checks} {expr -~3} 4
Xtest expr-6.2 {precedence checks} {expr -!3} 0
Xtest expr-6.3 {precedence checks} {expr -~0} 1
X
Xtest expr-7.1 {precedence checks} {expr 2*4/6} 1
Xtest expr-7.2 {precedence checks} {expr 24/6*3} 12
Xtest expr-7.3 {precedence checks} {expr 24/6/2} 2
X
Xtest expr-8.1 {precedence checks} {expr -2+4} 2
Xtest expr-8.2 {precedence checks} {expr -2-4} -6
X
Xtest expr-9.1 {precedence checks} {expr 2*3+4} 10
Xtest expr-9.2 {precedence checks} {expr 8/2+4} 8
Xtest expr-9.3 {precedence checks} {expr 8%3+4} 6
Xtest expr-9.4 {precedence checks} {expr 2*3-1} 5
Xtest expr-9.5 {precedence checks} {expr 8/2-1} 3
Xtest expr-9.6 {precedence checks} {expr 8%3-1} 1
X
Xtest expr-10.1 {precedence checks} {expr 6-3-2} 1
X
Xtest expr-11.1 {precedence checks} {expr 7+1>>2} 2
Xtest expr-11.2 {precedence checks} {expr 7+1<<2} 32
Xtest expr-11.3 {precedence checks} {expr 7>>3-2} 3
Xtest expr-11.4 {precedence checks} {expr 7<<3-2} 14
X
Xtest expr-12.1 {precedence checks} {expr 6>>1>4} 0
Xtest expr-12.2 {precedence checks} {expr 6>>1<2} 0
Xtest expr-12.3 {precedence checks} {expr 6>>1>=3} 1
Xtest expr-12.4 {precedence checks} {expr 6>>1<=2} 0
Xtest expr-12.5 {precedence checks} {expr 6<<1>5} 1
Xtest expr-12.6 {precedence checks} {expr 6<<1<5} 0
Xtest expr-12.7 {precedence checks} {expr 5<=6<<1} 1
Xtest expr-12.8 {precedence checks} {expr 5>=6<<1} 0
X
Xtest expr-13.1 {precedence checks} {expr 2<3<4} 1
Xtest expr-13.2 {precedence checks} {expr 0<4>2} 0
Xtest expr-13.3 {precedence checks} {expr 4>2<1} 0
Xtest expr-13.4 {precedence checks} {expr 4>3>2} 0
Xtest expr-13.5 {precedence checks} {expr 4>3>=2} 0
Xtest expr-13.6 {precedence checks} {expr 4>=3>2} 0
Xtest expr-13.7 {precedence checks} {expr 4>=3>=2} 0
Xtest expr-13.8 {precedence checks} {expr 0<=4>=2} 0
Xtest expr-13.9 {precedence checks} {expr 4>=2<=0} 0
Xtest expr-10.10 {precedence checks} {expr 2<=3<=4} 1
X
Xtest expr-14.1 {precedence checks} {expr 1==4>3} 1
Xtest expr-14.2 {precedence checks} {expr 0!=4>3} 1
Xtest expr-14.3 {precedence checks} {expr 1==3<4} 1
Xtest expr-14.4 {precedence checks} {expr 0!=3<4} 1
Xtest expr-14.5 {precedence checks} {expr 1==4>=3} 1
Xtest expr-14.6 {precedence checks} {expr 0!=4>=3} 1
Xtest expr-14.7 {precedence checks} {expr 1==3<=4} 1
Xtest expr-14.8 {precedence checks} {expr 0!=3<=4} 1
X
Xtest expr-15.1 {precedence checks} {expr 1==3==3} 0
Xtest expr-15.2 {precedence checks} {expr 3==3!=2} 1
Xtest expr-15.3 {precedence checks} {expr 2!=3==3} 0
Xtest expr-15.4 {precedence checks} {expr 2!=1!=1} 0
X
Xtest expr-16.1 {precedence checks} {expr 2&3==2} 0
Xtest expr-16.2 {precedence checks} {expr 1&3!=3} 0
X
Xtest expr-17.1 {precedence checks} {expr 7&3^0x10} 19
Xtest expr-17.2 {precedence checks} {expr 7^0x10&3} 7
X
Xtest expr-18.1 {precedence checks} {expr 7^0x10|3} 23
Xtest expr-18.2 {precedence checks} {expr 7|0x10^3} 23
X
Xtest expr-19.1 {precedence checks} {expr 7|3&&1} 1
Xtest expr-19.2 {precedence checks} {expr 1&&3|7} 1
Xtest expr-19.3 {precedence checks} {expr 0&&1||1} 1
Xtest expr-19.4 {precedence checks} {expr 1||1&&0} 1
X
Xtest expr-20.1 {precedence checks} {expr 1||0?3:4} 3
Xtest expr-20.2 {precedence checks} {expr 1?0:4||1} 0
X
X# Parentheses.
X
Xtest expr-21.1 {parenthesization} {expr (2+4)*6} 36
Xtest expr-21.2 {parenthesization} {expr (1?0:4)||1} 1
X
X# Embedded commands and variable names.
X
Xset a 16
Xtest expr-22.1 {embedded variables} {expr {2*$a}} 32
Xtest expr-22.2 {embedded variables} {
X set x -5
X set y 10
X expr {$x + $y}
X} {5}
Xtest expr-22.3 {embedded commands and variables} {expr {[set a] - 14}} 2
Xtest expr-22.4 {embedded commands and variables} {
X list [catch {expr {12 - [bad_command_name]}} msg] $msg
X} {1 {invalid command name: "bad_command_name"}}
X
X# Double-quotes and things inside them.
X
Xtest expr-23.1 {double-quotes} {expr {"abc"}} abc
Xtest expr-23.2 {double-quotes} {
X set a 189
X expr {"$a.bc"}
X} 189.bc
Xtest expr-23.3 {double-quotes} {
X set b2 xyx
X expr {"$b2$b2$b2.[set b2].[set b2]"}
X} xyxxyxxyx.xyx.xyx
Xtest expr-23.4 {double-quotes} {expr {"11\}\}22"}} 11}}22
Xtest expr-23.5 {double-quotes} {expr {"\abc"}} {\abc}
Xtest expr-23.6 {double-quotes} {
X catch {unset bogus__}
X list [catch {expr {"$bogus__"}} msg] $msg
X} {1 {can't read "bogus__": no such variable}}
Xtest expr-23.7 {double-quotes} {
X list [catch {expr {"a[error Testing]bc"}} msg] $msg
X} {1 Testing}
X
X# Numbers in various bases.
X
Xtest expr-24.1 {numbers in different bases} {expr 0x20} 32
Xtest expr-24.2 {numbers in different bases} {expr 015} 13
X
X# Conversions between various data types.
X
Xtest expr-25.1 {type conversions} {expr 2+2.5} 4.5
Xtest expr-25.2 {type conversions} {expr 2.5+2} 4.5
Xtest expr-25.3 {type conversions} {expr 2-2.5} -0.5
Xtest expr-25.4 {type conversions} {expr 2/2.5} 0.8
Xtest expr-25.5 {type conversions} {expr 2>2.5} 0
Xtest expr-25.6 {type conversions} {expr 2.5>2} 1
Xtest expr-25.7 {type conversions} {expr 2<2.5} 1
Xtest expr-25.8 {type conversions} {expr 2>=2.5} 0
Xtest expr-25.9 {type conversions} {expr 2<=2.5} 1
Xtest expr-25.10 {type conversions} {expr 2==2.5} 0
Xtest expr-25.11 {type conversions} {expr 2!=2.5} 1
Xtest expr-25.12 {type conversions} {expr 2>"ab"} 0
Xtest expr-25.13 {type conversions} {expr {2>" "}} 1
Xtest expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1
Xtest expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0
Xtest expr-25.16 {type conversions} {expr 2+2.5} 4.5
Xtest expr-25.17 {type conversions} {expr 2+2.5} 4.5
X
X# Various error conditions.
X
Xtest expr-26.1 {error conditions} {
X list [catch {expr 2+"a"} msg] $msg

X} {1 {can't use non-numeric string as operand of "+"}}

Xtest expr-26.2 {error conditions} {
X list [catch {expr 2+4*} msg] $msg
X} {1 {syntax error in expression "2+4*"}}
Xtest expr-26.3 {error conditions} {
X list [catch {expr 2+4*(} msg] $msg
X} {1 {syntax error in expression "2+4*("}}
Xcatch {unset _non_existent_}
Xtest expr-26.4 {error conditions} {
X list [catch {expr 2+$_non_existent_} msg] $msg
X} {1 {can't read "_non_existent_": no such variable}}
Xset a xx
Xtest expr-26.5 {error conditions} {
X list [catch {expr {2+$a}} msg] $msg

X} {1 {can't use non-numeric string as operand of "+"}}

Xtest expr-26.6 {error conditions} {
X list [catch {expr {2+[set a]}} msg] $msg

X} {1 {can't use non-numeric string as operand of "+"}}

Xtest expr-26.7 {error conditions} {
X list [catch {expr {2+(4}} msg] $msg
X} {1 {unmatched parentheses in expression "2+(4"}}
Xtest expr-26.8 {error conditions} {
X list [catch {expr 2/0} msg] $msg
X} {1 {divide by zero}}
Xtest expr-26.9 {error conditions} {
X list [catch {expr 2%0} msg] $msg
X} {1 {divide by zero}}
Xtest expr-26.10 {error conditions} {
X list [catch {expr 2#} msg] $msg
X} {1 {syntax error in expression "2#"}}
Xtest expr-26.11 {error conditions} {
X list [catch {expr a.b} msg] $msg
X} {1 {syntax error in expression "a.b"}}
Xtest expr-26.12 {error conditions} {
X list [catch {expr {"a"/"b"}} msg] $msg
X} {1 {can't use non-numeric string as operand of "/"}}
Xtest expr-26.13 {error conditions} {
X list [catch {expr 2:3} msg] $msg
X} {1 {can't have : operator without ? first}}
Xtest expr-26.14 {error conditions} {
X list [catch {expr a@b} msg] $msg
X} {1 {syntax error in expression "a@b"}}
Xtest expr-26.15 {error conditions} {
X list [catch {expr a@b} msg] $msg
X} {1 {syntax error in expression "a@b"}}
Xtest expr-26.16 {error conditions} {
X list [catch {expr a[b} msg] $msg
X} {1 {missing close-bracket}}
Xtest expr-26.17 {error conditions} {
X list [catch {expr a`b} msg] $msg
X} {1 {syntax error in expression "a`b"}}
Xtest expr-26.18 {error conditions} {
X list [catch {expr \"a\"\{b} msg] $msg
X} {1 {missing close-brace}}
Xtest expr-26.19 {error conditions} {
X list [catch {expr a} msg] $msg
X} {1 {syntax error in expression "a"}}
X
X# Cancelled evaluation.
X
Xtest expr-27.1 {cancelled evaluation} {
X set a 1
X expr {0&&[set a 2]}

X set a
X} 1

Xtest expr-27.2 {cancelled evaluation} {
X set a 1
X expr {1||[set a 2]}

X set a
X} 1

Xtest expr-27.3 {cancelled evaluation} {
X set a 1
X expr {0?[set a 2]:1}

X set a
X} 1

Xtest expr-27.4 {cancelled evaluation} {
X set a 1
X expr {1?2:[set a 2]}

X set a
X} 1
X

X# Tcl_ExprBool as used in "if" statements
X
Xtest expr-28.1 {Tcl_ExprBoolean usage} {
X set a 1
X if {2} {
X set a 2
X }
X set a
X} 2
Xtest expr-28.2 {Tcl_ExprBoolean usage} {
X set a 1
X if {0} {
X set a 2

X }
X set a
X} 1

Xtest expr-28.3 {Tcl_ExprBoolean usage} {
X set a 1
X if {1.2} {
X set a 2
X }
X set a
X} 2
Xtest expr-28.4 {Tcl_ExprBoolean usage} {
X set a 1
X if {-1.1} {
X set a 2
X }
X set a
X} 2
Xtest expr-28.5 {Tcl_ExprBoolean usage} {
X set a 1
X if {0.0} {
X set a 2

X }
X set a
X} 1

Xtest expr-28.6 {Tcl_ExprBool usage} {
X list [catch {if {"abc"} {}} msg] $msg

X} {1 {expression didn't have numeric value}}
X

X# Operands enclosed in braces
X
Xtest expr-29.1 {braces} {expr {{abc}}} abc
Xtest expr-29.2 {braces} {expr {{00010}}} 8
Xtest expr-29.3 {braces} {expr {{3.1200000}}} 3.12
Xtest expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c"
Xtest expr-29.5 {braces} {
X list [catch {expr "\{abc"} msg] $msg
X} {1 {missing close-brace}}
X
X# Very long values
X
Xtest expr-30.1 {long values} {
X set a "0000 1111 2222 3333 4444"
X set a "$a | $a | $a | $a | $a"
X set a "$a || $a || $a || $a || $a"
X expr {$a}
X} {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 \
X4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 \
X3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 \
X2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 \
X1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | \
X0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 \
X4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 \
X3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 \
X2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444}
Xtest expr-30.2 {long values} {
X set a "000000000000000000000000000000"
X set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5"
X expr $a
X} 5
END_OF_FILE
if test 19899 -ne `wc -c <'tcl6.1/tests/expr.test'`; then
echo shar: \"'tcl6.1/tests/expr.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/expr.test'
fi
echo shar: End of archive 14 $of 33$.
cp /dev/null ark14isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:47:03 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 83
Archive-name: tcl/part15
Environment: UNIX

# "End of archive 15 (of 33)."
# Contents: tcl6.1/tests/scan.test tcl6.1/tests/trace.test
# Wrapped by karl@one on Tue Nov 12 19:44:23 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tests/scan.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/scan.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/scan.test'\" $20188 characters$
sed "s/^X//" >'tcl6.1/tests/scan.test' <<'END_OF_FILE'
X# Commands covered: scan

X# $Header: /user6/ouster/tcl/tests/RCS/scan.test,v 1.9 91/10/17 16:25:28 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xtest scan-1.1 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-20 1476 \n33 0" "%d %d %d %d" a b c d
X} 4
Xtest scan-1.2 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-20 1476 \n33 0" "%d %d %d %d" a b c d
X set a
X} -20
Xtest scan-1.3 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-20 1476 \n33 0" "%d %d %d %d" a b c d
X set b
X} 1476
Xtest scan-1.4 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-20 1476 \n33 0" "%d %d %d %d" a b c d
X set c
X} 33
Xtest scan-1.5 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-20 1476 \n33 0" "%d %d %d %d" a b c d
X set d
X} 0
Xtest scan-1.6 {integer scanning} {
X set a {}; set b {}; set c {}
X scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c
X} 3
Xtest scan-1.7 {integer scanning} {
X set a {}; set b {}; set c {}
X scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c
X set a
X} -4
Xtest scan-1.8 {integer scanning} {
X set a {}; set b {}; set c {}
X scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c
X set b
X} 16
Xtest scan-1.9 {integer scanning} {
X set a {}; set b {}; set c {}
X scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c
X set c
X} 7890
Xtest scan-1.10 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-45 16 +10 987" "%D %d %D %d" a b c d
X} 4
Xtest scan-1.11 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-45 16 +10 987" "%D %d %D %d" a b c d
X set a
X} -45
Xtest scan-1.12 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-45 16 +10 987" "%D %d%D %d" a b c d
X set b
X} 16
Xtest scan-1.13 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-45 16 +10 987" "%D %d %D %d" a b c d
X set c
X} 10
Xtest scan-1.14 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-45 16 +10 987" "%D %d %D %d" a b c d
X set d
X} 987
Xtest scan-1.15 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "14 1ab 62 10" "%d %x %O %x" a b c d
X} 4
Xtest scan-1.16 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "14 1ab 62 10" "%d %x %O %x" a b c d
X set a
X} 14
Xtest scan-1.17 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "14 1ab 62 10" "%d %x %O %x" a b c d
X set b
X} 427
Xtest scan-1.18 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "14 1ab 62 10" "%d %x %O %x" a b c d
X set c
X} 50
Xtest scan-1.19 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "14 1ab 62 10" "%d %x %O %x" a b c d
X set d
X} 16
Xtest scan-1.20 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345670 1234567890ab cdefg" "%o %o %x %X" a b c d
X} 4
Xtest scan-1.21 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345670 1234567890ab cdefg" "%o %o %x %X" a b c d
X set a
X} 2739128
Xtest scan-1.22 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345670 1234567890ab cdefg" "%o %o %x %X" a b c d
X set b
X} 342391
Xtest scan-1.23 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345670 1234567890ab cdefg" "%o %o %x %X" a b c d
X set c
X} 561323
Xtest scan-1.24 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345670 1234567890ab cdefg" "%o %o %x %X" a b c d
X set d
X} 52719
Xtest scan-1.25 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "ab123-24642" "%2x %3x %3o %2o" a b c d
X} 4
Xtest scan-1.26 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "ab123-24642" "%2x %3x %3o %2o" a b c d
X set a
X} 171
Xtest scan-1.27 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "ab123-24642" "%2x %3x %3o %2o" a b c d
X set b
X} 291
Xtest scan-1.28 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "ab123-24642" "%2x %3x %3o %2o" a b c d
X set c
X} -20
Xtest scan-1.29 {integer scanning} {
X set a {}; set b {}
X scan "ab123-24642" "%2x %3x %3o %2o" a b c d
X set d
X} 52
Xtest scan-1.30 {integer scanning} {
X set a {}; set b {}
X scan "1234567 234 567 " "%*3x %x %*o %4o" a b
X} 2
Xtest scan-1.31 {integer scanning} {
X set a {}; set b {}
X scan "1234567 234 567 " "%*3x %x %*o %4o" a b
X set a
X} 17767
Xtest scan-1.32 {integer scanning} {
X set a {}; set b {}
X scan "a 1234" "%d %d" a b
X} 0
Xtest scan-1.33 {integer scanning} {
X set a {}
X scan "a 1234" "%d %d" a b
X set a
X} {}
Xtest scan-1.34 {integer scanning} {
X set a {}; set b {}; set c {}; set d {};
X scan "12345678" "%2d %2d %2d %2d" a b c d
X} 4
Xtest scan-1.35 {integer scanning} {
X set a {}; set b {}; set c {}; set d {};
X scan "12345678" "%2d %2d %2d %2d" a b c d
X set a
X} 12
Xtest scan-1.36 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345678" "%2d %2d %2d %2d" a b c d
X set b
X} 34
Xtest scan-1.37 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345678" "%2d %2d %2d %2d" a b c d
X set c
X} 56
Xtest scan-1.38 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "12345678" "%2d %2d %2d %2d" a b c d
X set d
X} 78
Xtest scan-1.39 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2 " "%d %d %d %d" a b c d
X} 2
Xtest scan-1.40 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2 " "%d %d %d %d" a b c d

X set a
X} 1

Xtest scan-1.41 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2 " "%d %d %d %d" a b c d

X set b
X} 2

Xtest scan-1.42 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2 " "%d %d %d %d" a b c d
X} 2
Xtest scan-1.43 {integer scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2 " "%d %d %d %d" a b c d
X set d
X} {}
X
Xtest scan-2.1 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "2.1 -3.0e8 .99962 a" "%f%f%f%f" a b c d
X} 3
Xtest scan-2.2 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "2.1 -3.0e8 .99962 a" "%f%f%f%f" a b c d
X set a
X} 2.1
Xtest scan-2.3 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "2.1 -3.0e8 .99962 a" "%f%f%f%f" a b c d
X set b
X} -3e+08
Xtest scan-2.4 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "2.1 -3.0e8 .99962 a" "%f%f%f%f" a b c d
X set c
X} 0.99962
Xtest scan-2.5 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "2.1 -3.0e8 .99962 a" "%f%f%f%f" a b c d
X set d
X} {}
Xtest scan-2.6 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-1.2345 +8.2 9" "%3e %3f %f %f" a b c d
X} 4
Xtest scan-2.7 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-1.2345 +8.2 9" "%3e %3f %f %f" a b c d
X set a
X} -1
Xtest scan-2.8 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-1.2345 +8.2 9" "%3e %3f %f %f" a b c d
X set b
X} 234
Xtest scan-2.9 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-1.2345 +8.2 9" "%3e %3f %f %f" a b c d
X set c
X} 5
Xtest scan-2.10 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "-1.2345 +8.2 9" "%3e %3f %f %f" a b c d
X set d
X} 8.2
Xtest scan-2.11 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1e00004 332E-4 3e+4" "%f %*2e %f %f" a b c
X} 3
Xtest scan-2.12 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1e00004 332E-4 3e+4" "%f %*2e %f %f" a b c
X set a
X} 10000
Xtest scan-2.13 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1e00004 332E-4 3e+4" "%f %*2e %f %f" a b c
X set c
X} 30000
Xtest scan-2.14 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c
X} 3
Xtest scan-2.15 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c

X set a
X} 1

Xtest scan-2.16 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c
X set b
X} 200
Xtest scan-2.17 {floating-point scanning} {
X set a {}; set b {}; set c {}
X scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c
X set c
X} 3
Xtest scan-2.18 {floating-point scanning} {
X set a {}; set b {}
X scan "1.eabc" "%f %x" a b
X} 2
Xtest scan-2.19 {floating-point scanning} {
X set a {}; set b {}
X scan "1.eabc" "%f %x" a b

X set a
X} 1

Xtest scan-2.20 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d
X} 4
Xtest scan-2.21 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d
X set a
X} 4.6
Xtest scan-2.22 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d
X set b
X} 99999.7
Xtest scan-2.23 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d
X set c
X} 87.643
Xtest scan-2.24 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d
X set d
X} 118
Xtest scan-2.25 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d
X} 4
Xtest scan-2.26 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d
X set a
X} 1.2345
Xtest scan-2.27 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d
X set b
X} 0.697
Xtest scan-2.28 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d
X set c
X} 124
Xtest scan-2.29 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d
X set d
X} 5e-05
Xtest scan-2.30 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6abc" "%f %f %f %f" a b c d
X} 1
Xtest scan-2.31 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6abc" "%f %f %f %f" a b c d
X set a
X} 4.6
Xtest scan-2.32 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6abc" "%f %f %f %f" a b c d
X set b
X} {}
Xtest scan-2.33 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6abc" "%f %f %f %f" a b c d
X set c
X} {}
Xtest scan-2.34 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6abc" "%f %f %f %f" a b c d
X set d
X} {}
Xtest scan-2.35 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 5.2" "%f %f %f %f" a b c d
X} 2
Xtest scan-2.36 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 5.2" "%f %f %f %f" a b c d
X set a
X} 4.6
Xtest scan-2.37 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 5.2" "%f %f %f %f" a b c d
X set b
X} 5.2
Xtest scan-2.38 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 5.2" "%f %f %f %f" a b c d
X set c
X} {}
Xtest scan-2.39 {floating-point scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "4.6 5.2" "%f %f %f %f" a b c d
X set d
X} {}
X
Xtest scan-3.1 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "abc defghijk dum " "%s %3s %20s %s" a b c d
X} 4
Xtest scan-3.2 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "abc defghijk dum " "%s %3s %20s %s" a b c d
X set a
X} abc
Xtest scan-3.3 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "abc defghijk dum " "%s %3s %20s %s" a b c d
X set b
X} def
Xtest scan-3.4 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "abc defghijk dum " "%s %3s %20s %s" a b c d
X set c
X} ghijk
Xtest scan-3.5 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "abc defghijk dum " "%s %3s %20s %s" a b c d
X set d
X} dum
Xtest scan-3.6 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "a bcdef" "%c%c%1s %s" a b c d
X} 4
Xtest scan-3.7 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "a bcdef" "%c%c%1s %s" a b c d
X set a
X} 97
Xtest scan-3.8 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "a bcdef" "%c%c%1s %s" a b c d
X set b
X} 32
Xtest scan-3.9 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "a bcdef" "%c%c%1s %s" a b c d
X set c
X} b
Xtest scan-3.10 {string and character scanning} {
X set a {}; set b {}; set c {}; set d {}
X scan "a bcdef" "%c%c%1s %s" a b c d
X set d
X} cdef
Xtest scan-3.11 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "123456 test " "%*c%*s %s %s %s" a b c
X} 1
Xtest scan-3.12 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "123456 test " "%*c%*s %s %s %s" a b c

X set a
X} test

Xtest scan-3.13 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "123456 test " "%*c%*s %s %s %s" a b c
X set b
X} {}
Xtest scan-3.14 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "123456 test " "%*c%*s %s %s %s" a b c
X set c
X} {}
Xtest scan-3.15 {string and character scanning} {
X set a {}; set b {}; set c {}; set d
X scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d
X} 4
Xtest scan-3.16 {string and character scanning} {
X set a {}; set b {}; set c {}; set d
X scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d
X set a
X} abab
Xtest scan-3.17 {string and character scanning} {
X set a {}; set b {}; set c {}; set d
X scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d
X set b
X} cd
Xtest scan-3.18 {string and character scanning} {
X set a {}; set b {}; set c {}; set d
X scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d
X set c
X} {01234 }
Xtest scan-3.19 {string and character scanning} {
X set a {}; set b {}; set c {}; set d
X scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d
X set d
X} {f 12345}
Xtest scan-3.20 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c
X} 3
Xtest scan-3.21 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c
X set a
X} aabc
Xtest scan-3.22 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c
X set b
X} bcdefg
Xtest scan-3.23 {string and character scanning} {
X set a {}; set b {}; set c {}
X scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c
X set c
X} 43
X
Xtest scan-4.1 {error conditions} {
X catch {scan a}
X} 1
Xtest scan-4.2 {error conditions} {
X catch {scan a} msg
X set msg
X} {wrong # args: should be "scan string format ?varName varName ...?"}
Xtest scan-4.3 {error conditions} {
X catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" \
X"%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" \
Xa1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21}
X} 1
Xtest scan-4.4 {error conditions} {
X catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" \
X"%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" \
Xa1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg
X set msg
X} {too many fields to scan}
Xtest scan-4.5 {error conditions} {
X catch {scan a %z}
X} 1
Xtest scan-4.6 {error conditions} {
X catch {scan a %z} msg
X set msg
X} {bad scan conversion character "z"}
Xtest scan-4.7 {error conditions} {
X catch {scan a "%d %d" a}
X} 1
Xtest scan-4.8 {error conditions} {
X catch {scan a "%d %d" a} msg
X set msg
X} {different numbers of variable names and field specifiers}
Xtest scan-4.9 {error conditions} {
X catch {scan a "%d %d" a b c}
X} 1
Xtest scan-4.10 {error conditions} {
X catch {scan a "%d %d" a b c} msg
X set msg
X} {different numbers of variable names and field specifiers}
Xtest scan-4.11 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}
X} 1
Xtest scan-4.12 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan " a" " a %d %d %d %d" a b c d
X set a
X} {}
Xtest scan-4.13 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan " a" " a %d %d %d %d" a b c d
X set b
X} {}
Xtest scan-4.14 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan " a" " a %d %d %d %d" a b c d
X set c
X} {}
Xtest scan-4.15 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan " a" " a %d %d %d %d" a b c d
X set d
X} {}
Xtest scan-4.16 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2" "%d %d %d %d" a b c d
X} 2
Xtest scan-4.17 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2" "%d %d %d %d" a b c d

X set a
X} 1

Xtest scan-4.18 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2" "%d %d %d %d" a b c d

X set b
X} 2

Xtest scan-4.19 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2" "%d %d %d %d" a b c d
X set c
X} {}
Xtest scan-4.20 {error conditions} {
X set a {}; set b {}; set c {}; set d {}
X scan "1 2" "%d %d %d %d" a b c d
X set d
X} {}
Xtest scan-4.21 {error conditions} {

X catch {unset a}
X set a(0) 44

X list [catch {scan 44 %d a} msg] $msg
X} {1 {couldn't set variable "a"}}
Xtest scan-4.22 {error conditions} {

X catch {unset a}
X set a(0) 44

X list [catch {scan 44 %c a} msg] $msg
X} {1 {couldn't set variable "a"}}
Xtest scan-4.23 {error conditions} {

X catch {unset a}
X set a(0) 44

X list [catch {scan 44 %s a} msg] $msg
X} {1 {couldn't set variable "a"}}
Xtest scan-4.24 {error conditions} {

X catch {unset a}
X set a(0) 44

X list [catch {scan 44 %f a} msg] $msg
X} {1 {couldn't set variable "a"}}
Xtest scan-4.25 {error conditions} {

X catch {unset a}
X set a(0) 44

X list [catch {scan 44 %f a} msg] $msg
X} {1 {couldn't set variable "a"}}
Xcatch {unset a}
Xtest scan-4.26 {error conditions} {
X list [catch {scan 44 %2c a} msg] $msg
X} {1 {field width may not be specified in %c conversion}}
X
Xtest scan-5.1 {lots of arguments} {
X scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 \
X200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 \
Xa4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
X} 20
Xtest scan-5.2 {lots of arguments} {
X scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 \
X200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 \
Xa4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
X set a20
X} 200
END_OF_FILE
if test 20188 -ne `wc -c <'tcl6.1/tests/scan.test'`; then
echo shar: \"'tcl6.1/tests/scan.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/scan.test'
fi
if test -f 'tcl6.1/tests/trace.test' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tests/trace.test'\"
else
echo shar: Extracting \"'tcl6.1/tests/trace.test'\" $20398 characters$
sed "s/^X//" >'tcl6.1/tests/trace.test' <<'END_OF_FILE'
X# Commands covered: trace

X# $Header: /user6/ouster/tcl/tests/RCS/trace.test,v 1.11 91/10/31 16:40:51 ouster Exp $ (Berkeley)

X
Xif {[string compare test [info procs test]] == 1} then {source defs}
X

Xproc traceScalar {name1 name2 op} {
X global info
X set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
X}
Xproc traceArray {name1 name2 op} {
X global info
X set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
X}
Xproc traceProc {name1 name2 op} {
X global info
X set info [concat $info [list $name1 $name2 $op]]
X}
Xproc traceTag {tag args} {
X global info
X set info [concat $info $tag]
X}
Xproc traceError {args} {
X error error
X}
Xproc traceCheck {cmd args} {
X global info
X set info [list [catch $cmd msg] $msg]
X}
X
X# Read-tracing on variables
X
Xtest trace-1.1 {trace variable reads} {
X catch {unset x}
X set info {}
X trace var x r traceScalar
X list [catch {set x} msg] $msg $info
X} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}}
Xtest trace-1.2 {trace variable reads} {
X catch {unset x}
X set x 123
X set info {}
X trace var x r traceScalar
X list [catch {set x} msg] $msg $info
X} {0 123 {x {} r 0 123}}
Xtest trace-1.3 {trace variable reads} {
X catch {unset x}
X set info {}
X trace var x r traceScalar
X set x 123
X set info
X} {}
Xtest trace-1.4 {trace array element reads} {
X catch {unset x}
X set info {}
X trace var x(2) r traceArray
X list [catch {set x(2)} msg] $msg $info
X} {1 {can't read "x(2)": no such variable} {x 2 r 1 {can't read "x(2)": no such variable}}}
Xtest trace-1.5 {trace array element reads} {
X catch {unset x}
X set x(2) zzz
X set info {}
X trace var x(2) r traceArray
X list [catch {set x(2)} msg] $msg $info
X} {0 zzz {x 2 r 0 zzz}}
Xtest trace-1.6 {trace reads on whole arrays} {
X catch {unset x}
X set info {}
X trace var x r traceArray
X list [catch {set x(2)} msg] $msg $info
X} {1 {can't read "x(2)": no such variable} {}}
Xtest trace-1.7 {trace reads on whole arrays} {
X catch {unset x}
X set x(2) zzz
X set info {}
X trace var x r traceArray
X list [catch {set x(2)} msg] $msg $info
X} {0 zzz {x 2 r 0 zzz}}
Xtest trace-1.8 {trace variable reads} {
X catch {unset x}
X set x 444
X set info {}
X trace var x r traceScalar
X unset x
X set info
X} {}
X
X# Basic write-tracing on variables
X
Xtest trace-2.1 {trace variable writes} {
X catch {unset x}
X set info {}
X trace var x w traceScalar
X set x 123
X set info
X} {x {} w 0 123}
Xtest trace-2.2 {trace writes to array elements} {
X catch {unset x}
X set info {}
X trace var x(33) w traceArray
X set x(33) 444
X set info
X} {x 33 w 0 444}
Xtest trace-2.3 {trace writes on whole arrays} {
X catch {unset x}
X set info {}
X trace var x w traceArray
X set x(abc) qq
X set info
X} {x abc w 0 qq}
Xtest trace-2.4 {trace variable writes} {
X catch {unset x}
X set x 1234
X set info {}
X trace var x w traceScalar
X set x
X set info
X} {}
Xtest trace-2.5 {trace variable writes} {
X catch {unset x}
X set x 1234
X set info {}
X trace var x w traceScalar
X unset x
X set info
X} {}
X
X# Basic unset-tracing on variables
X
Xtest trace-3.1 {trace variable unsets} {
X catch {unset x}
X set info {}
X trace var x u traceScalar
X catch {unset x}
X set info
X} {x {} u 1 {can't read "x": no such variable}}
Xtest trace-3.2 {variable mustn't exist during unset trace} {
X catch {unset x}
X set x 1234
X set info {}
X trace var x u traceScalar
X unset x
X set info
X} {x {} u 1 {can't read "x": no such variable}}
Xtest trace-3.3 {unset traces mustn't be called during reads and writes} {
X catch {unset x}
X set info {}
X trace var x u traceScalar
X set x 44
X set x
X set info
X} {}
Xtest trace-3.4 {trace unsets on array elements} {
X catch {unset x}
X set x(0) 18
X set info {}
X trace var x(1) u traceArray
X catch {unset x(1)}
X set info
X} {x 1 u 1 {can't read "x(1)": no such element in array}}
Xtest trace-3.5 {trace unsets on array elements} {
X catch {unset x}
X set x(1) 18
X set info {}
X trace var x(1) u traceArray
X unset x(1)
X set info
X} {x 1 u 1 {can't read "x(1)": no such element in array}}
Xtest trace-3.6 {trace unsets on array elements} {
X catch {unset x}
X set x(1) 18
X set info {}
X trace var x(1) u traceArray
X unset x
X set info
X} {x 1 u 1 {can't read "x(1)": no such variable}}
Xtest trace-3.7 {trace unsets on whole arrays} {
X catch {unset x}
X set x(1) 18
X set info {}
X trace var x u traceProc
X catch {unset x(0)}
X set info
X} {}
Xtest trace-3.8 {trace unsets on whole arrays} {
X catch {unset x}
X set x(1) 18
X set info {}
X trace var x u traceProc
X unset x(1)
X set info
X} {x 1 u}
Xtest trace-3.9 {trace unsets on whole arrays} {
X catch {unset x}
X set x(1) 18
X set info {}
X trace var x u traceProc
X unset x
X set info
X} {x {} u}
X
X# Trace multiple trace types at once.
X
Xtest trace-4.1 {multiple ops traced at once} {
X catch {unset x}
X set info {}
X trace var x rwu traceProc
X catch {set x}
X set x 22
X set x
X set x 33
X unset x
X set info
X} {x {} r x {} w x {} r x {} w x {} u}
Xtest trace-4.2 {multiple ops traced on array element} {
X catch {unset x}
X set info {}
X trace var x(0) rwu traceProc
X catch {set x(0)}
X set x(0) 22
X set x(0)
X set x(0) 33
X unset x(0)
X unset x
X set info
X} {x 0 r x 0 w x 0 r x 0 w x 0 u}
Xtest trace-4.3 {multiple ops traced on whole array} {
X catch {unset x}
X set info {}
X trace var x rwu traceProc
X catch {set x(0)}
X set x(0) 22
X set x(0)
X set x(0) 33
X unset x(0)
X unset x
X set info
X} {x 0 w x 0 r x 0 w x 0 u x {} u}
X
X# Check order of invocation of traces
X
Xtest trace-5.1 {order of invocation of traces} {
X catch {unset x}
X set info {}
X trace var x r "traceTag 1"
X trace var x r "traceTag 2"
X trace var x r "traceTag 3"
X catch {set x}
X set x 22
X set x
X set info
X} {3 2 1 3 2 1}
Xtest trace-5.2 {order of invocation of traces} {
X catch {unset x}
X set x(0) 44
X set info {}
X trace var x(0) r "traceTag 1"
X trace var x(0) r "traceTag 2"
X trace var x(0) r "traceTag 3"
X set x(0)
X set info
X} {3 2 1}
Xtest trace-5.3 {order of invocation of traces} {
X catch {unset x}
X set x(0) 44
X set info {}
X trace var x(0) r "traceTag 1"
X trace var x r "traceTag A1"
X trace var x(0) r "traceTag 2"
X trace var x r "traceTag A2"
X trace var x(0) r "traceTag 3"
X trace var x r "traceTag A3"
X set x(0)
X set info
X} {A3 A2 A1 3 2 1}
X
X# Check effects of errors in trace procedures
X
Xtest trace-6.1 {error returns from traces} {
X catch {unset x}
X set x 123
X set info {}
X trace var x r "traceTag 1"
X trace var x r error
X list [catch {set x} msg] $msg $info
X} {1 {can't read "x": access disallowed by trace command} {}}
Xtest trace-6.2 {error returns from traces} {
X catch {unset x}
X set x 123
X set info {}
X trace var x w "traceTag 1"
X trace var x w error
X list [catch {set x 44} msg] $msg $info

X} {1 {can't set "x": access disallowed by trace command} {}}

Xtest trace-6.3 {error returns from traces} {
X catch {unset x}
X set x 123
X set info {}
X trace var x u "traceTag 1"
X trace var x u error
X list [catch {unset x} msg] $msg $info
X} {0 {} 1}
Xtest trace-6.4 {error returns from traces} {
X catch {unset x}
X set x(0) 123
X set info {}
X trace var x(0) r "traceTag 1"
X trace var x r "traceTag 2"
X trace var x r error
X trace var x r "traceTag 3"
X list [catch {set x(0)} msg] $msg $info
X} {1 {can't read "x(0)": access disallowed by trace command} 3}
X
X# Check to see that variables are expunged before trace
X# procedures are invoked, so trace procedure can even manipulate
X# a new copy of the variables.
X
Xtest trace-7.1 {be sure variable is unset before trace is called} {
X catch {unset x}
X set x 33
X set info {}
X trace var x u {traceCheck {uplevel set x}}
X unset x
X set info
X} {1 {can't read "x": no such variable}}
Xtest trace-7.2 {be sure variable is unset before trace is called} {
X catch {unset x}
X set x 33
X set info {}
X trace var x u {traceCheck {uplevel set x 22}}
X unset x
X concat $info [list [catch {set x} msg] $msg]
X} {0 22 0 22}
Xtest trace-7.3 {be sure traces are cleared before unset trace called} {
X catch {unset x}
X set x 33
X set info {}
X trace var x u {traceCheck {uplevel trace vinfo x}}
X unset x
X set info
X} {0 {}}
Xtest trace-7.4 {set new trace during unset trace} {
X catch {unset x}
X set x 33
X set info {}
X trace var x u {traceCheck {global x; trace var x u traceProc}}
X unset x
X concat $info [trace vinfo x]
X} {0 {} {u traceProc}}
X
Xtest trace-8.1 {make sure array elements are unset before traces are called} {
X catch {unset x}
X set x(0) 33
X set info {}
X trace var x(0) u {traceCheck {uplevel set x(0)}}
X unset x(0)
X set info
X} {1 {can't read "x(0)": no such element in array}}
Xtest trace-8.2 {make sure array elements are unset before traces are called} {
X catch {unset x}
X set x(0) 33
X set info {}
X trace var x(0) u {traceCheck {uplevel set x(0) zzz}}
X unset x(0)
X concat $info [list [catch {set x(0)} msg] $msg]
X} {0 zzz 0 zzz}
Xtest trace-8.3 {array elements are unset before traces are called} {
X catch {unset x}
X set x(0) 33
X set info {}
X trace var x(0) u {traceCheck {global x; trace vinfo x(0)}}
X unset x(0)
X set info
X} {0 {}}
Xtest trace-8.4 {set new array element trace during unset trace} {
X catch {unset x}
X set x(0) 33
X set info {}
X trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}}
X catch {unset x(0)}
X concat $info [trace vinfo x(0)]
X} {0 {} {r {}}}
X
Xtest trace-9.1 {make sure arrays are unset before traces are called} {
X catch {unset x}
X set x(0) 33
X set info {}
X trace var x u {traceCheck {uplevel set x(0)}}
X unset x
X set info
X} {1 {can't read "x(0)": no such variable}}
Xtest trace-9.2 {make sure arrays are unset before traces are called} {
X catch {unset x}
X set x(y) 33
X set info {}
X trace var x u {traceCheck {uplevel set x(y) 22}}
X unset x
X concat $info [list [catch {set x(y)} msg] $msg]
X} {0 22 0 22}
Xtest trace-9.3 {make sure arrays are unset before traces are called} {
X catch {unset x}
X set x(y) 33
X set info {}
X trace var x u {traceCheck {uplevel array names x}}
X unset x
X set info
X} {1 {"x" isn't an array}}
Xtest trace-9.4 {make sure arrays are unset before traces are called} {
X catch {unset x}
X set x(y) 33
X set info {}
X set cmd {traceCheck {uplevel {trace vinfo x}}}
X trace var x u $cmd
X unset x
X set info
X} {0 {}}
Xtest trace-9.5 {set new array trace during unset trace} {
X catch {unset x}
X set x(y) 33
X set info {}
X trace var x u {traceCheck {global x; trace var x r {}}}
X unset x
X concat $info [trace vinfo x]
X} {0 {} {r {}}}
Xtest trace-9.6 {create scalar during array unset trace} {
X catch {unset x}
X set x(y) 33
X set info {}
X trace var x u {traceCheck {global x; set x 44}}
X unset x
X concat $info [list [catch {set x} msg] $msg]

X} {0 44 0 44}
X

X# Check special conditions (e.g. errors) in Tcl_TraceVar2.
X
Xtest trace-10.1 {creating array when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x(0) w traceProc
X list [catch {set x 22} msg] $msg
X} {1 {can't set "x": variable is array}}
Xtest trace-10.2 {creating array when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x(0) w traceProc
X list [catch {set x(0)} msg] $msg
X} {1 {can't read "x(0)": no such variable}}
Xtest trace-10.3 {creating array when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x(0) w traceProc
X set x(0) 22
X set info
X} {x 0 w}
Xtest trace-10.4 {creating variable when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x w traceProc
X list [catch {set x} msg] $msg
X} {1 {can't read "x": no such variable}}
Xtest trace-10.5 {creating variable when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x w traceProc
X set x 22
X set info
X} {x {} w}
Xtest trace-10.6 {creating variable when setting variable traces} {
X catch {unset x}
X set info {}
X trace var x w traceProc
X set x(0) 22
X set info
X} {x 0 w}
Xtest trace-10.7 {errors when setting variable traces} {
X catch {unset x}
X set x 44
X list [catch {trace var x(0) w traceProc} msg] $msg
X} {1 {variable isn't array}}
X
X# Check deleting one trace from another.
X
Xtest trace-11.1 {delete one trace from another} {
X proc delTraces {args} {
X global x
X trace vdel x r {traceTag 2}
X trace vdel x r {traceTag 3}
X trace vdel x r {traceTag 4}
X }
X catch {unset x}
X set x 44
X set info {}
X trace var x r {traceTag 1}
X trace var x r {traceTag 2}
X trace var x r {traceTag 3}
X trace var x r {traceTag 4}
X trace var x r delTraces
X trace var x r {traceTag 5}
X set x
X set info
X} {5 1}
X
X# Check operation and syntax of "trace" command.
X
Xtest trace-12.1 {trace command (overall)} {
X list [catch {trace} msg] $msg
X} {1 {too few args: should be "trace option [arg arg ...]"}}
Xtest trace-12.2 {trace command (overall)} {
X list [catch {trace gorp} msg] $msg
X} {1 {bad option "gorp": should be variable, vdelete, or vinfo}}
Xtest trace-12.3 {trace command ("variable" option)} {
X list [catch {trace variable x y} msg] $msg
X} {1 {wrong # args: should be "trace variable name ops command"}}
Xtest trace-12.4 {trace command ("variable" option)} {
X list [catch {trace var x y z z2} msg] $msg
X} {1 {wrong # args: should be "trace variable name ops command"}}
Xtest trace-12.5 {trace command ("variable" option)} {
X list [catch {trace var x y z} msg] $msg
X} {1 {bad operations "y": should be one or more of rwu}}
Xtest trace-12.6 {trace command ("vdelete" option)} {
X list [catch {trace vdelete x y} msg] $msg
X} {1 {wrong # args: should be "trace vdelete name ops command"}}
Xtest trace-12.7 {trace command ("vdelete" option)} {
X list [catch {trace vdelete x y z foo} msg] $msg
X} {1 {wrong # args: should be "trace vdelete name ops command"}}
Xtest trace-12.8 {trace command ("vdelete" option)} {
X list [catch {trace vdelete x y z} msg] $msg
X} {1 {bad operations "y": should be one or more of rwu}}
Xtest trace-12.9 {trace command ("vdelete" option)} {
X catch {unset x}
X set info {}
X trace var x w traceProc
X trace vdelete x w traceProc
X} {}
Xtest trace-12.10 {trace command ("vdelete" option)} {
X catch {unset x}
X set info {}
X trace var x w traceProc
X trace vdelete x w traceProc
X set x 12345
X set info
X} {}
Xtest trace-12.11 {trace command ("vdelete" option)} {
X catch {unset x}
X set info {}
X trace var x w {traceTag 1}
X trace var x w traceProc
X trace var x w {traceTag 2}
X set x yy
X trace vdelete x w traceProc
X set x 12345
X trace vdelete x w {traceTag 1}
X set x foo
X trace vdelete x w {traceTag 2}
X set x gorp
X set info
X} {2 x {} w 1 2 1 2}
Xtest trace-12.12 {trace command ("vdelete" option)} {
X catch {unset x}
X set info {}
X trace var x w {traceTag 1}
X trace vdelete x w non_existent
X set x 12345

X set info
X} {1}

Xtest trace-12.13 {trace command ("vinfo" option)} {
X list [catch {trace vinfo} msg] $msg]
X} {1 {wrong # args: should be "trace vinfo name"]}}
Xtest trace-12.14 {trace command ("vinfo" option)} {
X list [catch {trace vinfo x y} msg] $msg]
X} {1 {wrong # args: should be "trace vinfo name"]}}
Xtest trace-12.15 {trace command ("vinfo" option)} {
X catch {unset x}
X trace var x w {traceTag 1}
X trace var x w traceProc
X trace var x w {traceTag 2}
X trace vinfo x
X} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}}
Xtest trace-12.16 {trace command ("vinfo" option)} {
X catch {unset x}
X trace vinfo x
X} {}
Xtest trace-12.17 {trace command ("vinfo" option)} {
X catch {unset x}
X trace vinfo x(0)
X} {}
Xtest trace-12.18 {trace command ("vinfo" option)} {
X catch {unset x}
X set x 44
X trace vinfo x(0)
X} {}
Xtest trace-12.19 {trace command ("vinfo" option)} {
X catch {unset x}
X set x 44
X trace var x w {traceTag 1}
X proc check {} {global x; trace vinfo x}
X check
X} {{w {traceTag 1}}}
X
X# Check fancy trace commands (long ones, weird arguments, etc.)
X
Xtest trace-13.1 {long trace command} {
X catch {unset x}
X set info {}
X trace var x w {traceTag {This is a very very long argument. It's \
X designed to test out the facilities of TraceVarProc for dealing \
X with such long arguments by malloc-ing space. One possibility \
X is that space doesn't get freed properly. If this happens, then \
X invoking this test over and over again will eventually leak memory.}}
X set x 44
X set info
X} {This is a very very long argument. It's \
X designed to test out the facilities of TraceVarProc for dealing \
X with such long arguments by malloc-ing space. One possibility \
X is that space doesn't get freed properly. If this happens, then \
X invoking this test over and over again will eventually leak memory.}
Xtest trace-13.2 {long trace command result to ignore} {
X proc longResult {args} {return "quite a bit of text, designed to
X generate a core leak if this command file is invoked over and over again
X and memory isn't being recycled correctly"}
X catch {unset x}
X trace var x w longResult
X set x 44
X set x 5
X set x abcde
X} abcde
Xtest trace-13.3 {special list-handling in trace commands} {
X catch {unset "x y z"}
X set "x y z(a\n\{)" 44
X set info {}
X trace var "x y z(a\n\{)" w traceProc
X set "x y z(a\n\{)" 33
X set info
X} "{x y z} a\\n\{ w"
X
X# Check for things that are illegal while a trace is active (such
X# as deleting a variable).
X
Xtest trace-14.1 {unsets must be disallowed during traces} {
X catch {unset x}
X set x 123
X set info {}
X trace var x r {traceCheck {global x; unset x}}
X set x
X concat $info [list [catch {set x} msg] $msg]
X} {1 {can't unset "x": trace is active on variable} 0 123}
Xtest trace-14.2 {unsets must be disallowed during traces} {
X catch {unset x}
X set x 123
X set info {}
X trace var x r {traceCheck {uplevel {unset x}}}
X set x
X concat $info [list [catch {set x} msg] $msg]
X} {1 {can't unset "x": trace is active on variable} 0 123}
Xtest trace-14.3 {unsets must be disallowed during traces} {
X catch {unset x}
X set x(14) 123
X set info {}
X trace var x(14) r {traceCheck {uplevel {unset x}}}
X set x(14)
X concat $info [list [catch {set x(14)} msg] $msg]
X} {1 {can't unset "x": trace is active on variable} 0 123}
X
X# Check various non-interference between traces and other things.
X
Xtest trace-15.1 {trace doesn't prevent unset errors} {
X catch {unset x}
X set info {}
X trace var x u {traceProc}
X list [catch {unset x} msg] $msg $info
X} {1 {can't set "x": no such element in array} {x {} u}}
Xtest trace-15.2 {traced variables must survive procedure exits} {
X catch {unset x}
X proc p1 {} {global x; trace var x w traceProc}
X p1
X trace vinfo x
X} {{w traceProc}}
Xtest trace-15.3 {traced variables must survive procedure exits} {
X catch {unset x}
X set info {}
X proc p1 {} {global x; trace var x w traceProc}
X p1
X set x 44
X set info
X} {x {} w}
X
X# Be sure that procedure frames are released before unset traces
X# are invoked.
X
Xtest trace-16.1 {unset traces on procedure returns} {
X proc p1 {x y} {set a 44; p2 14}
X proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}}
X set info {}
X p1 foo bar
X set info
X} {0 {a x y}}
X
X# Delete arrays when done, so they can be re-used as scalars
X# elsewhere.
X
Xcatch {unset x}
Xreturn ""
END_OF_FILE
if test 20398 -ne `wc -c <'tcl6.1/tests/trace.test'`; then
echo shar: \"'tcl6.1/tests/trace.test'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tests/trace.test'
fi
echo shar: End of archive 15 $of 33$.
cp /dev/null ark15isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:47:24 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 84
Archive-name: tcl/part16
Environment: UNIX

# "End of archive 16 (of 33)."
# Contents: tcl6.1/tclCmdAH.c tcl6.1/tclHash.c
# Wrapped by karl@one on Tue Nov 12 19:44:24 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclCmdAH.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclCmdAH.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCmdAH.c'\" $21838 characters$
sed "s/^X//" >'tcl6.1/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-1991 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: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.73 91/11/07 09:02:11 ouster Exp $ SPRITE (Berkeley)";

X#endif
X
X#include "tclInt.h"
X

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 Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], "\"", (char *) NULL);
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 int caseArgc, splitArgs;
X char **caseArgv;
X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " string ?in? patList body ... ?default body?\"",

X (char *) NULL);
X return TCL_ERROR;
X }

X string = argv[1];
X body = -1;
X if (strcmp(argv[2], "in") == 0) {
X i = 3;
X } else {
X i = 2;
X }
X caseArgc = argc - i;
X caseArgv = argv + i;
X
X /*
X * If all of the pattern/command pairs are lumped into a single
X * argument, split them out again.
X */
X
X splitArgs = 0;
X if (caseArgc == 1) {
X result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);

X if (result != TCL_OK) {

X return result;
X }
X splitArgs = 1;
X }
X
X for (i = 0; i < caseArgc; i += 2) {
X int patArgc, j;
X char **patArgv;

X register char *p;
X

X if (i == (caseArgc-1)) {
X interp->result = "extra case pattern with no body";
X result = TCL_ERROR;
X goto cleanup;
X }
X
X /*
X * Check for special case of single pattern (no list) with
X * no backslash sequences.
X */
X
X for (p = caseArgv[i]; *p != 0; p++) {
X if (isspace(*p) || (*p == '\\')) {
X break;
X }
X }

X if (*p == 0) {

X if ((*caseArgv[i] == 'd')
X && (strcmp(caseArgv[i], "default") == 0)) {
X body = i+1;
X }
X if (Tcl_StringMatch(string, caseArgv[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, caseArgv[i], &patArgc, &patArgv);

X if (result != TCL_OK) {

X goto cleanup;
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 != -1) {
X result = Tcl_Eval(interp, caseArgv[body], 0, (char **) NULL);
X if (result == TCL_ERROR) {
X char msg[100];
X sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[i],
X interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);
X }
X goto cleanup;
X }
X
X /*
X * Nothing matched: return nothing.
X */
X
X result = TCL_OK;
X
X cleanup:
X if (splitArgs) {
X ckfree((char *) caseArgv);

X }
X return result;
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 Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " command ?varName?\"", (char *) NULL);
X return TCL_ERROR;
X }
X result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
X if (argc == 3) {
X if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
X Tcl_SetResult(interp, "couldn't save command result in variable",
X TCL_STATIC);

X return TCL_ERROR;
X }
X }

X Tcl_ResetResult(interp);
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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " arg ?arg ...?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X interp->result = Tcl_Concat(argc-1, argv+1);
X interp->freeProc = (Tcl_FreeProc *) free;
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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X "\"", (char *) NULL);
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 Interp *iPtr = (Interp *) interp;
X
X if ((argc < 2) || (argc > 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " message ?errorInfo? ?errorCode?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if ((argc >= 3) && (argv[2][0] != 0)) {
X Tcl_AddErrorInfo(interp, argv[2]);
X iPtr->flags |= ERR_ALREADY_LOGGED;
X }
X if (argc == 4) {
X Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
X TCL_GLOBAL_ONLY);
X iPtr->flags |= ERROR_CODE_SET;
X }
X Tcl_SetResult(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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " arg ?arg ...?\"", (char *) NULL);
X return TCL_ERROR;
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, "\n (\"eval\" body line %d)", interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);
X }
X return result;
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 if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " expression\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X return Tcl_ExprString(interp, argv[1]);
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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " start test next command\"", (char *) NULL);

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, "\n (\"for\" initial command)");

X }
X return result;
X }

X while (1) {
X result = Tcl_ExprBoolean(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, "\n (\"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, "\n (\"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_ResetResult(interp);

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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " varName list command\"", (char *) NULL);

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 if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
X Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
X result = TCL_ERROR;
X break;
X }
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, "\n (\"foreach\" body line %d)",
X 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_ResetResult(interp);

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 = NULL; /* 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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " formatString ?arg arg ...?\"", (char *) NULL);
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 = p = format;
X while ((*format != '%') && (*format != 0)) {
X if (*format == '\\') {
X *p = Tcl_Backslash(format, &bsSize);
X if (*p != 0) {
X p++;
X }
X format += bsSize;
X } else {
X *p = *format;
X p++;
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 while ((*format == '-') || (*format == '#')) {
X *newPtr = *format;
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 if (Tcl_GetInt(interp, *curArg, &width) != TCL_OK) {
X goto fmtError;
X }
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 if (Tcl_GetInt(interp, *curArg, &precision) != TCL_OK) {
X goto fmtError;
X }
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 == '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 'O':
X case 'U':
X *newPtr = tolower(*format);
X newPtr[-1] = 'l';
X newPtr++;
X *newPtr = 0;
X case 'd':
X case 'o':
X case 'u':
X case 'x':
X case 'X':
X if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
X != TCL_OK) {
X goto fmtError;
X }
X size = 40;
X break;
X case 's':
X oneWordValue = *curArg;
X size = strlen(*curArg);
X break;
X case 'c':
X if (Tcl_GetInt(interp, *curArg, (int *) &oneWordValue)
X != TCL_OK) {
X goto fmtError;
X }
X size = 1;
X break;
X case 'F':
X newPtr[-1] = tolower(newPtr[-1]);
X case 'e':
X case 'E':
X case 'f':
X case 'g':
X case 'G':
X if (Tcl_GetDouble(interp, *curArg, &twoWordValue) != TCL_OK) {
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 =
X "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 memcpy((VOID *) newDst, (VOID *) dst, dstSize);
X }
X if (dstSpace != TCL_RESULT_SIZE) {
X ckfree(dst);
X }
X dst = newDst;
X dstSpace = newSpace;
X }
X if (noPercent) {
X memcpy((VOID *) dst+dstSize, (VOID *) oneWordValue, 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 if (dstSpace != TCL_RESULT_SIZE) {
X interp->freeProc = (Tcl_FreeProc *) free;
X } else {
X interp->freeProc = 0;

X }
X return TCL_OK;
X

X notEnoughArgs:
X interp->result = "not enough arguments for all format specifiers";
X fmtError:
X if (dstSpace != TCL_RESULT_SIZE) {
X ckfree(dst);
X }
X return TCL_ERROR;
X}
END_OF_FILE
if test 21838 -ne `wc -c <'tcl6.1/tclCmdAH.c'`; then
echo shar: \"'tcl6.1/tclCmdAH.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCmdAH.c'
fi
if test -f 'tcl6.1/tclHash.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclHash.c'\"
else
echo shar: Extracting \"'tcl6.1/tclHash.c'\" $25018 characters$
sed "s/^X//" >'tcl6.1/tclHash.c' <<'END_OF_FILE'
X/*
X * tclHash.c --
X *
X * Implementation of in-memory hash tables for Tcl and Tcl-based
X * applications.

Xstatic char rcsid[] = "$Header: /sprite/src/lib/tcl/RCS/tclHash.c,v 1.8 91/07/22 11:46:00 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X
X/*
X * Imported library procedures for which there are no header files:
X */
X
Xextern void panic();
X
X/*
X * When there are this many entries per bucket, on average, rebuild
X * the hash table to make it larger.
X */
X
X#define REBUILD_MULTIPLIER 3
X
X
X/*
X * The following macro takes a preliminary integer hash value and
X * produces an index into a hash tables bucket list. The idea is
X * to make it so that preliminary values that are arbitrarily similar
X * will end up in different buckets. The hash function was taken
X * from a random-number generator.
X */
X
X#define RANDOM_INDEX(tablePtr, i) \
X (((((int) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
X
X/*
X * Procedure prototypes for static procedures in this file:
X */
X
Xstatic Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X char *key));
Xstatic Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,

X char *key, int *newPtr));

Xstatic Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X char *key));
Xstatic Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,

X char *key, int *newPtr));

Xstatic int HashString _ANSI_ARGS_((char *string));
Xstatic void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr));
Xstatic Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X char *key));
Xstatic Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,

X char *key, int *newPtr));

Xstatic Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
X char *key));
Xstatic Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,

X char *key, int *newPtr));

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_InitHashTable --
X *
X * Given storage for a hash table, set up the fields to prepare
X * the hash table for use.

X *
X * Results:
X * None.
X *
X * Side effects:

X * TablePtr is now ready to be passed to Tcl_FindHashEntry and
X * Tcl_CreateHashEntry.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_InitHashTable(tablePtr, keyType)
X register Tcl_HashTable *tablePtr; /* Pointer to table record, which
X * is supplied by the caller. */
X int keyType; /* Type of keys to use in table:
X * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
X * or an integer >= 2. */
X{
X tablePtr->buckets = tablePtr->staticBuckets;
X tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
X tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
X tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
X tablePtr->numEntries = 0;
X tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
X tablePtr->downShift = 28;
X tablePtr->mask = 3;
X tablePtr->keyType = keyType;
X if (keyType == TCL_STRING_KEYS) {
X tablePtr->findProc = StringFind;
X tablePtr->createProc = StringCreate;
X } else if (keyType == TCL_ONE_WORD_KEYS) {
X tablePtr->findProc = OneWordFind;
X tablePtr->createProc = OneWordCreate;
X } else {
X tablePtr->findProc = ArrayFind;
X tablePtr->createProc = ArrayCreate;
X };
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_DeleteHashEntry --
X *
X * Remove a single entry from a hash table.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The entry given by entryPtr is deleted from its table and
X * should never again be used by the caller. It is up to the
X * caller to free the clientData field of the entry, if that
X * is relevant.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DeleteHashEntry(entryPtr)
X Tcl_HashEntry *entryPtr;
X{
X register Tcl_HashEntry *prevPtr;
X
X if (*entryPtr->bucketPtr == entryPtr) {
X *entryPtr->bucketPtr = entryPtr->nextPtr;
X } else {
X for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) {
X if (prevPtr == NULL) {
X panic("malformed bucket chain in Tcl_DeleteHashEntry");
X }
X if (prevPtr->nextPtr == entryPtr) {
X prevPtr->nextPtr = entryPtr->nextPtr;

X break;
X }
X }
X }

X entryPtr->tablePtr->numEntries--;
X ckfree((char *) entryPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DeleteHashTable --
X *
X * Free up everything associated with a hash table except for
X * the record for the table itself.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The hash table is no longer useable.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DeleteHashTable(tablePtr)
X register Tcl_HashTable *tablePtr; /* Table to delete. */
X{
X register Tcl_HashEntry *hPtr, *nextPtr;
X int i;
X
X /*
X * Free up all the entries in the table.
X */
X
X for (i = 0; i < tablePtr->numBuckets; i++) {
X hPtr = tablePtr->buckets[i];
X while (hPtr != NULL) {
X nextPtr = hPtr->nextPtr;
X ckfree((char *) hPtr);
X hPtr = nextPtr;
X }
X }
X
X /*
X * Free up the bucket array, if it was dynamically allocated.
X */
X
X if (tablePtr->buckets != tablePtr->staticBuckets) {
X ckfree((char *) tablePtr->buckets);
X }
X
X /*
X * Arrange for panics if the table is used again without
X * re-initialization.
X */
X
X tablePtr->findProc = BogusFind;
X tablePtr->createProc = BogusCreate;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_FirstHashEntry --
X *
X * Locate the first entry in a hash table and set up a record
X * that can be used to step through all the remaining entries
X * of the table.

X *
X * Results:

X * The return value is a pointer to the first entry in tablePtr,
X * or NULL if tablePtr has no entries in it. The memory at
X * *searchPtr is initialized so that subsequent calls to
X * Tcl_NextHashEntry will return all of the entries in the table,
X * one at a time.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

XTcl_HashEntry *
XTcl_FirstHashEntry(tablePtr, searchPtr)
X Tcl_HashTable *tablePtr; /* Table to search. */
X Tcl_HashSearch *searchPtr; /* Place to store information about
X * progress through the table. */
X{
X searchPtr->tablePtr = tablePtr;
X searchPtr->nextIndex = 0;
X searchPtr->nextEntryPtr = NULL;
X return Tcl_NextHashEntry(searchPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_NextHashEntry --
X *
X * Once a hash table enumeration has been initiated by calling
X * Tcl_FirstHashEntry, this procedure may be called to return
X * successive elements of the table.

X *
X * Results:

X * The return value is the next entry in the hash table being
X * enumerated, or NULL if the end of the table is reached.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

XTcl_HashEntry *
XTcl_NextHashEntry(searchPtr)
X register Tcl_HashSearch *searchPtr; /* Place to store information about
X * progress through the table. Must
X * have been initialized by calling
X * Tcl_FirstHashEntry. */

X{
X Tcl_HashEntry *hPtr;
X

X while (searchPtr->nextEntryPtr == NULL) {
X if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) {
X return NULL;
X }
X searchPtr->nextEntryPtr =
X searchPtr->tablePtr->buckets[searchPtr->nextIndex];
X searchPtr->nextIndex++;
X }
X hPtr = searchPtr->nextEntryPtr;
X searchPtr->nextEntryPtr = hPtr->nextPtr;
X return hPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_HashStats --
X *
X * Return statistics describing the layout of the hash table
X * in its hash buckets.

X *
X * Results:

X * The return value is a malloc-ed string containing information
X * about tablePtr. It is the caller's responsibility to free
X * this string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_HashStats(tablePtr)
X Tcl_HashTable *tablePtr; /* Table for which to produce stats. */
X{
X#define NUM_COUNTERS 10
X int count[NUM_COUNTERS], overflow, i, j;
X double average, tmp;
X register Tcl_HashEntry *hPtr;
X char *result, *p;
X
X /*
X * Compute a histogram of bucket usage.
X */
X
X for (i = 0; i < NUM_COUNTERS; i++) {
X count[i] = 0;
X }
X overflow = 0;
X average = 0.0;
X for (i = 0; i < tablePtr->numBuckets; i++) {
X j = 0;
X for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) {
X j++;
X }
X if (j < NUM_COUNTERS) {
X count[j]++;
X } else {
X overflow++;
X }
X tmp = j;
X average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
X }
X
X /*
X * Print out the histogram and a few other pieces of information.
X */
X
X result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
X sprintf(result, "%d entries in table, %d buckets\n",
X tablePtr->numEntries, tablePtr->numBuckets);
X p = result + strlen(result);
X for (i = 0; i < NUM_COUNTERS; i++) {
X sprintf(p, "number of buckets with %d entries: %d\n",
X i, count[i]);
X p += strlen(p);
X }
X sprintf(p, "number of buckets with more %d or more entries: %d\n",
X NUM_COUNTERS, overflow);
X p += strlen(p);
X sprintf(p, "average search distance for entry: %.1f", average);
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * HashString --
X *
X * Compute a one-word summary of a text string, which can be
X * used to generate a hash index.

X *
X * Results:

X * The return value is a one-word summary of the information in
X * string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XHashString(string)
X register char *string; /* String from which to compute hash value. */
X{
X register int result, c;
X
X /*
X * I tried a zillion different hash functions and asked many other
X * people for advice. Many people had their own favorite functions,
X * all different, but no-one had much idea why they were good ones.
X * I chose the one below (multiply by 9 and add new character)
X * because of the following reasons:
X *
X * 1. Multiplying by 10 is perfect for keys that are decimal strings,
X * and multiplying by 9 is just about as good.
X * 2. Times-9 is (shift-left-3) plus (old). This means that each
X * character's bits hang around in the low-order bits of the
X * hash value for ever, plus they spread fairly rapidly up to
X * the high-order bits to fill out the hash value. This seems
X * works well both for decimal and non-decimal strings.
X */
X
X result = 0;
X while (1) {
X c = *string;
X string++;

X if (c == 0) {
X break;
X }

X result += (result<<3) + c;

X }
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * StringFind --
X *
X * Given a hash table with string keys, and a string key, find
X * the entry with a matching key.

X *
X * Results:

X * The return value is a token for the matching entry in the
X * hash table, or NULL if there was no matching entry.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XStringFind(tablePtr, key)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X char *key; /* Key to use to find matching entry. */
X{
X register Tcl_HashEntry *hPtr;

X register char *p1, *p2;

X int index;
X
X index = HashString(key) & tablePtr->mask;
X
X /*
X * Search all of the entries in the appropriate bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
X if (*p1 != *p2) {
X break;
X }
X if (*p1 == '\0') {
X return hPtr;
X }
X }
X }

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * StringCreate --
X *
X * Given a hash table with string keys, and a string key, find
X * the entry with a matching key. If there is no matching entry,
X * then create a new entry that does match.

X *
X * Results:

X * The return value is a pointer to the matching entry. If this
X * is a newly-created entry, then *newPtr will be set to a non-zero
X * value; otherwise *newPtr will be set to 0. If this is a new
X * entry the value stored in the entry will initially be 0.

X *
X * Side effects:

X * A new entry may be added to the hash table.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XStringCreate(tablePtr, key, newPtr)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X char *key; /* Key to use to find or create matching
X * entry. */
X int *newPtr; /* Store info here telling whether a new
X * entry was created. */
X{
X register Tcl_HashEntry *hPtr;

X register char *p1, *p2;

X int index;
X
X index = HashString(key) & tablePtr->mask;
X
X /*
X * Search all of the entries in this bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
X if (*p1 != *p2) {
X break;
X }
X if (*p1 == '\0') {
X *newPtr = 0;
X return hPtr;
X }
X }
X }
X
X /*
X * Entry not found. Add a new one to the bucket.
X */
X
X *newPtr = 1;
X hPtr = (Tcl_HashEntry *) ckalloc((unsigned)
X (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1)));
X hPtr->tablePtr = tablePtr;
X hPtr->bucketPtr = &(tablePtr->buckets[index]);
X hPtr->nextPtr = *hPtr->bucketPtr;
X hPtr->clientData = 0;
X strcpy(hPtr->key.string, key);
X *hPtr->bucketPtr = hPtr;
X tablePtr->numEntries++;
X
X /*
X * If the table has exceeded a decent size, rebuild it with many
X * more buckets.
X */
X
X if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X RebuildTable(tablePtr);
X }
X return hPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * OneWordFind --
X *
X * Given a hash table with one-word keys, and a one-word key, find
X * the entry with a matching key.

X *
X * Results:

X * The return value is a token for the matching entry in the
X * hash table, or NULL if there was no matching entry.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XOneWordFind(tablePtr, key)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X register char *key; /* Key to use to find matching entry. */
X{
X register Tcl_HashEntry *hPtr;
X int index;
X
X index = RANDOM_INDEX(tablePtr, key);
X
X /*
X * Search all of the entries in the appropriate bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X if (hPtr->key.oneWordValue == key) {
X return hPtr;
X }
X }

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * OneWordCreate --
X *
X * Given a hash table with one-word keys, and a one-word key, find
X * the entry with a matching key. If there is no matching entry,
X * then create a new entry that does match.

X *
X * Results:

X *
X * Side effects:

X * A new entry may be added to the hash table.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XOneWordCreate(tablePtr, key, newPtr)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X register char *key; /* Key to use to find or create matching
X * entry. */
X int *newPtr; /* Store info here telling whether a new
X * entry was created. */
X{
X register Tcl_HashEntry *hPtr;
X int index;
X
X index = RANDOM_INDEX(tablePtr, key);
X
X /*
X * Search all of the entries in this bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X if (hPtr->key.oneWordValue == key) {
X *newPtr = 0;
X return hPtr;
X }
X }
X
X /*
X * Entry not found. Add a new one to the bucket.
X */
X
X *newPtr = 1;
X hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry));
X hPtr->tablePtr = tablePtr;
X hPtr->bucketPtr = &(tablePtr->buckets[index]);
X hPtr->nextPtr = *hPtr->bucketPtr;
X hPtr->clientData = 0;
X hPtr->key.oneWordValue = key;
X *hPtr->bucketPtr = hPtr;
X tablePtr->numEntries++;
X
X /*
X * If the table has exceeded a decent size, rebuild it with many
X * more buckets.
X */
X
X if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X RebuildTable(tablePtr);
X }
X return hPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * ArrayFind --
X *
X * Given a hash table with array-of-int keys, and a key, find
X * the entry with a matching key.

X *
X * Results:

X * The return value is a token for the matching entry in the
X * hash table, or NULL if there was no matching entry.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XArrayFind(tablePtr, key)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X char *key; /* Key to use to find matching entry. */
X{
X register Tcl_HashEntry *hPtr;
X int *arrayPtr = (int *) key;
X register int *iPtr1, *iPtr2;
X int index, count;
X
X for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
X count > 0; count--, iPtr1++) {
X index += *iPtr1;
X }
X index = RANDOM_INDEX(tablePtr, index);
X
X /*
X * Search all of the entries in the appropriate bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
X count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
X if (count == 0) {
X return hPtr;
X }
X if (*iPtr1 != *iPtr2) {

X break;
X }
X }
X }

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * ArrayCreate --
X *
X * Given a hash table with one-word keys, and a one-word key, find
X * the entry with a matching key. If there is no matching entry,
X * then create a new entry that does match.

X *
X * Results:

X *
X * Side effects:

X * A new entry may be added to the hash table.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic Tcl_HashEntry *
XArrayCreate(tablePtr, key, newPtr)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X register char *key; /* Key to use to find or create matching
X * entry. */
X int *newPtr; /* Store info here telling whether a new
X * entry was created. */
X{
X register Tcl_HashEntry *hPtr;
X int *arrayPtr = (int *) key;
X register int *iPtr1, *iPtr2;
X int index, count;
X
X for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
X count > 0; count--, iPtr1++) {
X index += *iPtr1;
X }
X index = RANDOM_INDEX(tablePtr, index);
X
X /*
X * Search all of the entries in the appropriate bucket.
X */
X
X for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
X hPtr = hPtr->nextPtr) {
X for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
X count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
X if (count == 0) {
X *newPtr = 0;
X return hPtr;
X }
X if (*iPtr1 != *iPtr2) {

X break;
X }
X }
X }

X
X /*
X * Entry not found. Add a new one to the bucket.
X */
X
X *newPtr = 1;
X hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)
X + (tablePtr->keyType*sizeof(int)) - 4));
X hPtr->tablePtr = tablePtr;
X hPtr->bucketPtr = &(tablePtr->buckets[index]);
X hPtr->nextPtr = *hPtr->bucketPtr;
X hPtr->clientData = 0;
X for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType;
X count > 0; count--, iPtr1++, iPtr2++) {
X *iPtr2 = *iPtr1;
X }
X *hPtr->bucketPtr = hPtr;
X tablePtr->numEntries++;
X
X /*
X * If the table has exceeded a decent size, rebuild it with many
X * more buckets.
X */
X
X if (tablePtr->numEntries >= tablePtr->rebuildSize) {
X RebuildTable(tablePtr);
X }
X return hPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * BogusFind --
X *
X * This procedure is invoked when an Tcl_FindHashEntry is called
X * on a table that has been deleted.

X *
X * Results:

X * If panic returns (which it shouldn't) this procedure returns
X * NULL.

X *
X * Side effects:

X * Generates a panic.

X *
X *----------------------------------------------------------------------
X */
X

X /* ARGSUSED */
Xstatic Tcl_HashEntry *
XBogusFind(tablePtr, key)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X char *key; /* Key to use to find matching entry. */
X{
X panic("called Tcl_FindHashEntry on deleted table");

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * BogusCreate --
X *
X * This procedure is invoked when an Tcl_CreateHashEntry is called
X * on a table that has been deleted.

X *
X * Results:

X * If panic returns (which it shouldn't) this procedure returns
X * NULL.

X *
X * Side effects:

X * Generates a panic.

X *
X *----------------------------------------------------------------------
X */
X

X /* ARGSUSED */
Xstatic Tcl_HashEntry *
XBogusCreate(tablePtr, key, newPtr)
X Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
X char *key; /* Key to use to find or create matching
X * entry. */
X int *newPtr; /* Store info here telling whether a new
X * entry was created. */
X{
X panic("called Tcl_CreateHashEntry on deleted table");

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * RebuildTable --
X *
X * This procedure is invoked when the ratio of entries to hash
X * buckets becomes too large. It creates a new table with a
X * larger bucket array and moves all of the entries into the
X * new table.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Memory gets reallocated and entries get re-hashed to new
X * buckets.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XRebuildTable(tablePtr)
X register Tcl_HashTable *tablePtr; /* Table to enlarge. */
X{
X int oldSize, count, index;
X Tcl_HashEntry **oldBuckets;
X register Tcl_HashEntry **oldChainPtr, **newChainPtr;
X register Tcl_HashEntry *hPtr;
X
X oldSize = tablePtr->numBuckets;
X oldBuckets = tablePtr->buckets;
X
X /*
X * Allocate and initialize the new bucket array, and set up
X * hashing constants for new array size.
X */
X
X tablePtr->numBuckets *= 4;
X tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
X (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
X for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
X count > 0; count--, newChainPtr++) {
X *newChainPtr = NULL;
X }
X tablePtr->rebuildSize *= 4;
X tablePtr->downShift -= 2;
X tablePtr->mask = (tablePtr->mask << 2) + 3;
X
X /*
X * Rehash all of the existing entries into the new bucket array.
X */
X
X for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
X for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
X *oldChainPtr = hPtr->nextPtr;
X if (tablePtr->keyType == TCL_STRING_KEYS) {
X index = HashString(hPtr->key.string) & tablePtr->mask;
X } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
X index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue);
X } else {
X register int *iPtr;
X int count;
X
X for (index = 0, count = tablePtr->keyType,
X iPtr = hPtr->key.words; count > 0; count--, iPtr++) {
X index += *iPtr;
X }
X index = RANDOM_INDEX(tablePtr, index);
X }
X hPtr->bucketPtr = &(tablePtr->buckets[index]);
X hPtr->nextPtr = *hPtr->bucketPtr;
X *hPtr->bucketPtr = hPtr;
X }
X }
X
X /*
X * Free up the old bucket array, if it was dynamically allocated.
X */
X
X if (oldBuckets != tablePtr->staticBuckets) {
X ckfree((char *) oldBuckets);
X }
X}
END_OF_FILE
if test 25018 -ne `wc -c <'tcl6.1/tclHash.c'`; then
echo shar: \"'tcl6.1/tclHash.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclHash.c'
fi
echo shar: End of archive 16 $of 33$.
cp /dev/null ark16isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:47:45 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 85
Archive-name: tcl/part17
Environment: UNIX

# "End of archive 17 (of 33)."
# Contents: tcl6.1/tclBasic.c
# Wrapped by karl@one on Tue Nov 12 19:44:26 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclBasic.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclBasic.c'\"
else
echo shar: Extracting \"'tcl6.1/tclBasic.c'\" $27576 characters$
sed "s/^X//" >'tcl6.1/tclBasic.c' <<'END_OF_FILE'
X/*
X * tclBasic.c --
X *
X * Contains the basic facilities for TCL command interpretation,
X * including interpreter creation and deletion, command creation
X * and deletion, and command parsing and execution.
X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclBasic.c,v 1.128 91/10/31 16:41:13 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The following structure defines all of the commands in the Tcl core,
X * and the C procedures that execute them.
X */
X
Xtypedef struct {
X char *name; /* Name of command. */
X Tcl_CmdProc *proc; /* Procedure that executes command. */
X} CmdInfo;
X
X/*
X * Built-in commands, and the procedures associated with them:
X */
X
Xstatic CmdInfo builtInCmds[] = {
X /*
X * Commands in the generic core:
X */
X
X {"append", Tcl_AppendCmd},
X {"array", Tcl_ArrayCmd},
X {"break", Tcl_BreakCmd},
X {"case", Tcl_CaseCmd},
X {"catch", Tcl_CatchCmd},
X {"concat", Tcl_ConcatCmd},
X {"continue", Tcl_ContinueCmd},
X {"error", Tcl_ErrorCmd},
X {"eval", Tcl_EvalCmd},
X {"expr", Tcl_ExprCmd},
X {"for", Tcl_ForCmd},
X {"foreach", Tcl_ForeachCmd},
X {"format", Tcl_FormatCmd},
X {"global", Tcl_GlobalCmd},
X {"if", Tcl_IfCmd},
X {"incr", Tcl_IncrCmd},
X {"info", Tcl_InfoCmd},
X {"join", Tcl_JoinCmd},
X {"lappend", Tcl_LappendCmd},
X {"lindex", Tcl_LindexCmd},
X {"linsert", Tcl_LinsertCmd},
X {"list", Tcl_ListCmd},
X {"llength", Tcl_LlengthCmd},
X {"lrange", Tcl_LrangeCmd},
X {"lreplace", Tcl_LreplaceCmd},
X {"lsearch", Tcl_LsearchCmd},
X {"lsort", Tcl_LsortCmd},
X {"proc", Tcl_ProcCmd},
X {"regexp", Tcl_RegexpCmd},
X {"regsub", Tcl_RegsubCmd},
X {"rename", Tcl_RenameCmd},
X {"return", Tcl_ReturnCmd},
X {"scan", Tcl_ScanCmd},
X {"set", Tcl_SetCmd},
X {"split", Tcl_SplitCmd},
X {"string", Tcl_StringCmd},
X {"trace", Tcl_TraceCmd},
X {"unset", Tcl_UnsetCmd},
X {"uplevel", Tcl_UplevelCmd},
X {"upvar", Tcl_UpvarCmd},
X {"while", Tcl_WhileCmd},
X
X /*
X * Commands in the UNIX core:
X */
X
X#ifndef TCL_GENERIC_ONLY
X {"cd", Tcl_CdCmd},
X {"close", Tcl_CloseCmd},
X {"eof", Tcl_EofCmd},
X {"exec", Tcl_ExecCmd},
X {"exit", Tcl_ExitCmd},
X {"file", Tcl_FileCmd},
X {"flush", Tcl_FlushCmd},
X {"gets", Tcl_GetsCmd},
X {"glob", Tcl_GlobCmd},
X {"open", Tcl_OpenCmd},
X {"puts", Tcl_PutsCmd},
X {"pwd", Tcl_PwdCmd},
X {"read", Tcl_ReadCmd},
X {"seek", Tcl_SeekCmd},
X {"source", Tcl_SourceCmd},
X {"tell", Tcl_TellCmd},
X {"time", Tcl_TimeCmd},
X#endif /* TCL_GENERIC_ONLY */
X {NULL, (Tcl_CmdProc *) NULL}
X};

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CreateInterp --
X *
X * Create a new TCL command interpreter.

X *
X * Results:

X * The return value is a token for the interpreter, which may be
X * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or
X * Tcl_DeleteInterp.

X *
X * Side effects:

X * The command interpreter is initialized with an empty variable
X * table and the built-in commands.

X *
X *----------------------------------------------------------------------
X */
X

XTcl_Interp *
XTcl_CreateInterp()
X{
X register Interp *iPtr;
X register Command *cmdPtr;
X register CmdInfo *cmdInfoPtr;
X int i;
X
X iPtr = (Interp *) ckalloc(sizeof(Interp));
X iPtr->result = iPtr->resultSpace;
X iPtr->freeProc = 0;
X iPtr->errorLine = 0;
X Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
X Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS);
X iPtr->numLevels = 0;
X iPtr->framePtr = NULL;
X iPtr->varFramePtr = NULL;
X iPtr->activeTracePtr = NULL;
X iPtr->numEvents = 0;
X iPtr->events = NULL;
X iPtr->curEvent = 0;
X iPtr->curEventNum = 0;
X iPtr->revPtr = NULL;
X iPtr->historyFirst = NULL;
X iPtr->revDisables = 1;
X iPtr->evalFirst = iPtr->evalLast = NULL;
X iPtr->appendResult = NULL;
X iPtr->appendAvl = 0;
X iPtr->appendUsed = 0;
X iPtr->numFiles = 0;
X iPtr->filePtrArray = NULL;
X for (i = 0; i < NUM_REGEXPS; i++) {
X iPtr->patterns[i] = NULL;
X iPtr->regexps[i] = NULL;
X }
X iPtr->cmdCount = 0;
X iPtr->noEval = 0;
X iPtr->scriptFile = NULL;
X iPtr->flags = 0;
X iPtr->tracePtr = NULL;
X iPtr->resultSpace[0] = 0;
X
X /*
X * Create the built-in commands. Do it here, rather than calling
X * Tcl_CreateCommand, because it's faster (there's no need to
X * check for a pre-existing command by the same name).
X */
X
X for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
X int new;
X Tcl_HashEntry *hPtr;
X
X hPtr = Tcl_CreateHashEntry(&iPtr->commandTable,
X cmdInfoPtr->name, &new);
X if (new) {
X cmdPtr = (Command *) ckalloc(sizeof(Command));
X cmdPtr->proc = cmdInfoPtr->proc;
X cmdPtr->clientData = (ClientData) NULL;
X cmdPtr->deleteProc = NULL;
X Tcl_SetHashValue(hPtr, cmdPtr);
X }
X }
X
X#ifndef TCL_GENERIC_ONLY
X TclSetupEnv((Tcl_Interp *) iPtr);
X#endif
X
X return (Tcl_Interp *) iPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DeleteInterp --
X *
X * Delete an interpreter and free up all of the resources associated
X * with it.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The interpreter is destroyed. The caller should never again
X * use the interp token.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DeleteInterp(interp)
X Tcl_Interp *interp; /* Token for command interpreter (returned
X * by a previous call to Tcl_CreateInterp). */

X{
X Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr;
X Tcl_HashSearch search;
X register Command *cmdPtr;

X int i;
X
X /*

X * If the interpreter is in use, delay the deletion until later.
X */
X
X iPtr->flags |= DELETED;
X if (iPtr->numLevels != 0) {
X return;
X }
X
X /*
X * Free up any remaining resources associated with the
X * interpreter.
X */
X
X for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X if (cmdPtr->deleteProc != NULL) {
X (*cmdPtr->deleteProc)(cmdPtr->clientData);
X }
X ckfree((char *) cmdPtr);
X }
X Tcl_DeleteHashTable(&iPtr->commandTable);
X TclDeleteVars(iPtr, &iPtr->globalTable);
X if (iPtr->events != NULL) {
X int i;
X
X for (i = 0; i < iPtr->numEvents; i++) {
X ckfree(iPtr->events[i].command);
X }
X ckfree((char *) iPtr->events);
X }
X while (iPtr->revPtr != NULL) {
X HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
X
X ckfree((char *) iPtr->revPtr);
X iPtr->revPtr = nextPtr;
X }
X if (iPtr->appendResult != NULL) {
X ckfree(iPtr->appendResult);
X }
X#ifndef TCL_GENERIC_ONLY
X if (iPtr->numFiles > 0) {
X for (i = 0; i < iPtr->numFiles; i++) {
X OpenFile *filePtr;
X
X filePtr = iPtr->filePtrArray[i];
X if (filePtr == NULL) {
X continue;
X }
X if (i >= 3) {
X fclose(filePtr->f);
X if (filePtr->f2 != NULL) {
X fclose(filePtr->f2);
X }
X if (filePtr->numPids > 0) {
X Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
X ckfree((char *) filePtr->pidPtr);
X }
X }
X ckfree((char *) filePtr);
X }
X ckfree((char *) iPtr->filePtrArray);
X }
X#endif
X for (i = 0; i < NUM_REGEXPS; i++) {
X if (iPtr->patterns[i] == NULL) {
X break;
X }
X ckfree(iPtr->patterns[i]);
X ckfree((char *) iPtr->regexps[i]);
X }
X while (iPtr->tracePtr != NULL) {
X Trace *nextPtr = iPtr->tracePtr->nextPtr;
X
X ckfree((char *) iPtr->tracePtr);
X iPtr->tracePtr = nextPtr;
X }
X ckfree((char *) iPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CreateCommand --
X *
X * Define a new command in a command table.

X *
X * Results:
X * None.
X *
X * Side effects:

X * If a command named cmdName already exists for interp, it is
X * deleted. In the future, when cmdName is seen as the name of
X * a command by Tcl_Eval, proc will be called. When the command
X * is deleted from the table, deleteProc will be called. See the
X * manual entry for details on the calling sequence.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
X Tcl_Interp *interp; /* Token for command interpreter (returned
X * by a previous call to Tcl_CreateInterp). */
X char *cmdName; /* Name of command. */
X Tcl_CmdProc *proc; /* Command procedure to associate with
X * cmdName. */
X ClientData clientData; /* Arbitrary one-word value to pass to proc. */
X Tcl_CmdDeleteProc *deleteProc;
X /* If not NULL, gives a procedure to call when
X * this command is deleted. */

X{
X Interp *iPtr = (Interp *) interp;

X register Command *cmdPtr;
X Tcl_HashEntry *hPtr;
X int new;
X
X hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
X if (!new) {
X /*
X * Command already exists: delete the old one.
X */

X
X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X if (cmdPtr->deleteProc != NULL) {
X (*cmdPtr->deleteProc)(cmdPtr->clientData);
X }
X } else {
X cmdPtr = (Command *) ckalloc(sizeof(Command));
X Tcl_SetHashValue(hPtr, cmdPtr);
X }
X cmdPtr->proc = proc;
X cmdPtr->clientData = clientData;
X cmdPtr->deleteProc = deleteProc;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DeleteCommand --
X *
X * Remove the given command from the given interpreter.

X *
X * Results:

X * 0 is returned if the command was deleted successfully.
X * -1 is returned if there didn't exist a command by that
X * name.

X *
X * Side effects:

X * CmdName will no longer be recognized as a valid command for
X * interp.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_DeleteCommand(interp, cmdName)
X Tcl_Interp *interp; /* Token for command interpreter (returned
X * by a previous call to Tcl_CreateInterp). */
X char *cmdName; /* Name of command to remove. */

X{
X Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr;
X Command *cmdPtr;
X

X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);

X if (hPtr == NULL) {

X return -1;

X }
X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X if (cmdPtr->deleteProc != NULL) {
X (*cmdPtr->deleteProc)(cmdPtr->clientData);
X }
X ckfree((char *) cmdPtr);
X Tcl_DeleteHashEntry(hPtr);

X return 0;
X}
X
X/*
X *-----------------------------------------------------------------

X *
X * Tcl_Eval --
X *
X * Parse and execute a command in the Tcl language.

X *
X * Results:

X * The return value is one of the return codes defined in tcl.hd
X * (such as TCL_OK), and interp->result contains a string value
X * to supplement the return code. The value of interp->result
X * will persist only until the next call to Tcl_Eval: copy it or
X * lose it! *TermPtr is filled in with the character just after
X * the last one that was part of the command (usually a NULL
X * character or a closing bracket).

X *
X * Side effects:

X * Almost certainly; depends on the command.
X *
X *-----------------------------------------------------------------
X */
X
Xint
XTcl_Eval(interp, cmd, flags, termPtr)
X Tcl_Interp *interp; /* Token for command interpreter (returned
X * by a previous call to Tcl_CreateInterp). */
X char *cmd; /* Pointer to TCL command to interpret. */
X int flags; /* OR-ed combination of flags like
X * TCL_BRACKET_TERM and TCL_RECORD_BOUNDS. */
X char **termPtr; /* If non-NULL, fill in the address it points
X * to with the address of the char. just after
X * the last one that was part of cmd. See
X * the man page for details on this. */
X{
X /*
X * The storage immediately below is used to generate a copy
X * of the command, after all argument substitutions. Pv will
X * contain the argv values passed to the command procedure.
X */
X
X# define NUM_CHARS 200
X char copyStorage[NUM_CHARS];
X ParseValue pv;
X char *oldBuffer;
X
X /*
X * This procedure generates an (argv, argc) array for the command,
X * It starts out with stack-allocated space but uses dynamically-
X * allocated storage to increase it if needed.
X */
X
X# define NUM_ARGS 10
X char *(argStorage[NUM_ARGS]);
X char **argv = argStorage;
X int argc;
X int argSize = NUM_ARGS;
X
X register char *src; /* Points to current character
X * in cmd. */
X char termChar; /* Return when this character is found
X * (either ']' or '\0'). Zero means
X * that newlines terminate commands. */
X int result; /* Return value. */
X register Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr;
X Command *cmdPtr;

X char *dummy; /* Make termPtr point here if it was
X * originally NULL. */
X char *cmdStart; /* Points to first non-blank char. in
X * command (used in calling trace
X * procedures). */
X char *ellipsis = ""; /* Used in setting errorInfo variable;
X * set to "..." to indicate that not
X * all of offending command is included
X * in errorInfo. "" means that the
X * command is all there. */
X register Trace *tracePtr;
X
X /*
X * Initialize the result to an empty string and clear out any
X * error information. This makes sure that we return an empty
X * result if there are no commands in the command string.
X */
X
X Tcl_FreeResult((Tcl_Interp *) iPtr);
X iPtr->result = iPtr->resultSpace;
X iPtr->resultSpace[0] = 0;

X result = TCL_OK;
X

X /*
X * Check depth of nested calls to Tcl_Eval: if this gets too large,
X * it's probably because of an infinite loop somewhere.
X */
X
X iPtr->numLevels++;
X if (iPtr->numLevels > MAX_NESTING_DEPTH) {
X iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";

X return TCL_ERROR;
X }
X
X /*

X * Initialize the area in which command copies will be assembled.
X */
X
X pv.buffer = copyStorage;
X pv.end = copyStorage + NUM_CHARS - 1;
X pv.expandProc = TclExpandParseValue;
X pv.clientData = (ClientData) NULL;
X
X src = cmd;
X if (flags & TCL_BRACKET_TERM) {
X termChar = ']';
X } else {
X termChar = 0;
X }
X if (termPtr == NULL) {
X termPtr = &dummy;
X }
X *termPtr = src;
X cmdStart = src;
X
X /*
X * There can be many sub-commands (separated by semi-colons or
X * newlines) in one command string. This outer loop iterates over
X * individual commands.
X */
X
X while (*src != termChar) {
X iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET);
X
X /*
X * Skim off leading white space and semi-colons, and skip
X * comments.
X */
X
X while (1) {
X register char c = *src;
X
X if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) {
X break;
X }
X src += 1;
X }
X if (*src == '#') {
X for (src++; *src != 0; src++) {
X if (*src == '\n') {
X src++;
X break;
X }
X }
X continue;
X }
X cmdStart = src;
X
X /*
X * Parse the words of the command, generating the argc and
X * argv for the command procedure. May have to call
X * TclParseWords several times, expanding the argv array
X * between calls.
X */
X
X pv.next = oldBuffer = pv.buffer;
X argc = 0;
X while (1) {
X int newArgs, maxArgs;
X char **newArgv;

X int i;
X
X /*

X * Note: the "- 2" below guarantees that we won't use the
X * last two argv slots here. One is for a NULL pointer to
X * mark the end of the list, and the other is to leave room
X * for inserting the command name "unknown" as the first
X * argument (see below).
X */
X
X maxArgs = argSize - argc - 2;
X result = TclParseWords((Tcl_Interp *) iPtr, src, flags,
X maxArgs, termPtr, &newArgs, &argv[argc], &pv);
X src = *termPtr;

X if (result != TCL_OK) {

X ellipsis = "...";
X goto done;
X }
X
X /*
X * Careful! Buffer space may have gotten reallocated while
X * parsing words. If this happened, be sure to update all
X * of the older argv pointers to refer to the new space.
X */
X
X if (oldBuffer != pv.buffer) {
X int i;
X
X for (i = 0; i < argc; i++) {
X argv[i] = pv.buffer + (argv[i] - oldBuffer);
X }
X oldBuffer = pv.buffer;
X }
X argc += newArgs;
X if (newArgs < maxArgs) {
X argv[argc] = (char *) NULL;
X break;
X }
X
X /*
X * Args didn't all fit in the current array. Make it bigger.
X */
X
X argSize *= 2;
X newArgv = (char **)
X ckalloc((unsigned) argSize * sizeof(char *));
X for (i = 0; i < argc; i++) {
X newArgv[i] = argv[i];
X }
X if (argv != argStorage) {
X ckfree((char *) argv);
X }
X argv = newArgv;
X }
X
X /*
X * If this is an empty command (or if we're just parsing
X * commands without evaluating them), then just skip to the
X * next command.
X */
X
X if ((argc == 0) || iPtr->noEval) {
X continue;
X }
X argv[argc] = NULL;
X
X /*
X * Save information for the history module, if needed.
X */
X
X if (flags & TCL_RECORD_BOUNDS) {
X iPtr->evalFirst = cmdStart;
X iPtr->evalLast = src-1;
X }
X
X /*
X * Find the procedure to execute this command. If there isn't
X * one, then see if there is a command "unknown". If so,
X * invoke it instead, passing it the words of the original
X * command as arguments.
X */
X
X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]);

X if (hPtr == NULL) {

X int i;
X
X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown");

X if (hPtr == NULL) {

X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "invalid command name: \"",

X argv[0], "\"", (char *) NULL);

X result = TCL_ERROR;
X goto done;
X }
X for (i = argc; i >= 0; i--) {
X argv[i+1] = argv[i];
X }
X argv[0] = "unknown";
X argc++;

X }
X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X
X /*
X * Call trace procedures, if any.
X */
X
X for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
X tracePtr = tracePtr->nextPtr) {
X char saved;
X
X if (tracePtr->level < iPtr->numLevels) {
X continue;
X }
X saved = *src;
X *src = 0;
X (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
X cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv);
X *src = saved;
X }
X
X /*
X * At long last, invoke the command procedure. Reset the
X * result to its default empty value first (it could have
X * gotten changed by earlier commands in the same command
X * string).
X */
X
X iPtr->cmdCount++;
X Tcl_FreeResult(iPtr);
X iPtr->result = iPtr->resultSpace;
X iPtr->resultSpace[0] = 0;
X result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv);

X if (result != TCL_OK) {

X break;
X }
X }
X

X /*
X * Free up any extra resources that were allocated.
X */
X
X done:
X if (pv.buffer != copyStorage) {
X ckfree((char *) pv.buffer);
X }
X if (argv != argStorage) {
X ckfree((char *) argv);
X }
X iPtr->numLevels--;
X if (iPtr->numLevels == 0) {

X if (result == TCL_RETURN) {

X result = TCL_OK;
X }

X if ((result != TCL_OK) && (result != TCL_ERROR)) {
X Tcl_ResetResult(interp);

X if (result == TCL_BREAK) {

X iPtr->result = "invoked \"break\" outside of a loop";

X } else if (result == TCL_CONTINUE) {
X iPtr->result = "invoked \"continue\" outside of a loop";

X } else {
X iPtr->result = iPtr->resultSpace;
X sprintf(iPtr->resultSpace, "command returned bad code: %d",
X result);
X }

X result = TCL_ERROR;
X }

X if (iPtr->flags & DELETED) {
X Tcl_DeleteInterp(interp);

X }
X }
X
X /*

X * If an error occurred, record information about what was being
X * executed when the error occurred.
X */
X
X if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
X int numChars;

X register char *p;
X

X /*
X * Compute the line number where the error occurred.
X */
X
X iPtr->errorLine = 1;
X for (p = cmd; p != cmdStart; p++) {

X if (*p == '\n') {

X iPtr->errorLine++;
X }
X }
X for ( ; isspace(*p) || (*p == ';'); p++) {

X if (*p == '\n') {

X iPtr->errorLine++;

X }
X }
X
X /*

X * Figure out how much of the command to print in the error
X * message (up to a certain number of characters, or up to
X * the first new-line).
X */
X
X numChars = src - cmdStart;
X if (numChars > (NUM_CHARS-50)) {
X numChars = NUM_CHARS-50;
X ellipsis = " ...";
X }
X
X if (!(iPtr->flags & ERR_IN_PROGRESS)) {
X sprintf(copyStorage, "\n while executing\n\"%.*s%s\"",
X numChars, cmdStart, ellipsis);
X } else {
X sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"",
X numChars, cmdStart, ellipsis);
X }
X Tcl_AddErrorInfo(interp, copyStorage);
X iPtr->flags &= ~ERR_ALREADY_LOGGED;
X } else {
X iPtr->flags &= ~ERR_ALREADY_LOGGED;

X }
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CreateTrace --
X *
X * Arrange for a procedure to be called to trace command execution.

X *
X * Results:

X * The return value is a token for the trace, which may be passed
X * to Tcl_DeleteTrace to eliminate the trace.

X *
X * Side effects:

X * From now on, proc will be called just before a command procedure
X * is called to execute a Tcl command. Calls to proc will have the
X * following form:
X *
X * void
X * proc(clientData, interp, level, command, cmdProc, cmdClientData,
X * argc, argv)
X * ClientData clientData;
X * Tcl_Interp *interp;
X * int level;
X * char *command;
X * int (*cmdProc)();
X * ClientData cmdClientData;
X * int argc;
X * char **argv;
X * {
X * }
X *
X * The clientData and interp arguments to proc will be the same
X * as the corresponding arguments to this procedure. Level gives
X * the nesting level of command interpretation for this interpreter
X * (0 corresponds to top level). Command gives the ASCII text of
X * the raw command, cmdProc and cmdClientData give the procedure that
X * will be called to process the command and the ClientData value it
X * will receive, and argc and argv give the arguments to the
X * command, after any argument parsing and substitution. Proc
X * does not return a value.

X *
X *----------------------------------------------------------------------
X */
X

XTcl_Trace
XTcl_CreateTrace(interp, level, proc, clientData)
X Tcl_Interp *interp; /* Interpreter in which to create the trace. */
X int level; /* Only call proc for commands at nesting level
X * <= level (1 => top level). */
X Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
X * command. */
X ClientData clientData; /* Arbitrary one-word value to pass to proc. */
X{
X register Trace *tracePtr;
X register Interp *iPtr = (Interp *) interp;
X
X tracePtr = (Trace *) ckalloc(sizeof(Trace));
X tracePtr->level = level;
X tracePtr->proc = proc;
X tracePtr->clientData = clientData;
X tracePtr->nextPtr = iPtr->tracePtr;
X iPtr->tracePtr = tracePtr;
X
X return (Tcl_Trace) tracePtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DeleteTrace --
X *
X * Remove a trace.

X *
X * Results:
X * None.
X *
X * Side effects:

X * From now on there will be no more calls to the procedure given
X * in trace.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DeleteTrace(interp, trace)
X Tcl_Interp *interp; /* Interpreter that contains trace. */
X Tcl_Trace trace; /* Token for trace (returned previously by
X * Tcl_CreateTrace). */
X{
X register Interp *iPtr = (Interp *) interp;
X register Trace *tracePtr = (Trace *) trace;
X register Trace *tracePtr2;
X
X if (iPtr->tracePtr == tracePtr) {
X iPtr->tracePtr = tracePtr->nextPtr;
X ckfree((char *) tracePtr);
X } else {
X for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
X tracePtr2 = tracePtr2->nextPtr) {
X if (tracePtr2->nextPtr == tracePtr) {
X tracePtr2->nextPtr = tracePtr->nextPtr;
X ckfree((char *) tracePtr);
X return;
X }
X }
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AddErrorInfo --
X *
X * Add information to a message being accumulated that describes
X * the current error.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The contents of message are added to the "errorInfo" variable.
X * If Tcl_Eval has been called since the current value of errorInfo
X * was set, errorInfo is cleared before adding the new message.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_AddErrorInfo(interp, message)
X Tcl_Interp *interp; /* Interpreter to which error information
X * pertains. */
X char *message; /* Message to record. */
X{
X register Interp *iPtr = (Interp *) interp;
X
X /*
X * If an error is already being logged, then the new errorInfo
X * is the concatenation of the old info and the new message.
X * If this is the first piece of info for the error, then the
X * new errorInfo is the concatenation of the message in
X * interp->result and the new message.
X */
X
X if (!(iPtr->flags & ERR_IN_PROGRESS)) {
X Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
X TCL_GLOBAL_ONLY);
X iPtr->flags |= ERR_IN_PROGRESS;
X
X /*
X * If the errorCode variable wasn't set by the code that generated
X * the error, set it to "NONE".
X */
X
X if (!(iPtr->flags & ERROR_CODE_SET)) {
X (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
X TCL_GLOBAL_ONLY);
X }
X }
X Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message,
X TCL_GLOBAL_ONLY|TCL_APPEND_VALUE);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_VarEval --
X *
X * Given a variable number of string arguments, concatenate them
X * all together and execute the result as a Tcl command.

X *
X * Results:

X * A standard Tcl return result. An error message or other
X * result may be left in interp->result.

X *
X * Side effects:

X * Depends on what was done by the command.

X *
X *----------------------------------------------------------------------
X */

X /* VARARGS2 */ /* ARGSUSED */
Xint
X#ifndef lint
XTcl_VarEval(va_alist)
X#else
XTcl_VarEval(interp, p, va_alist)
X Tcl_Interp *interp; /* Interpreter in which to execute command. */
X char *p; /* One or more strings to concatenate,
X * terminated with a NULL string. */
X#endif
X va_dcl
X{
X va_list argList;
X#define FIXED_SIZE 200
X char fixedSpace[FIXED_SIZE+1];
X int spaceAvl, spaceUsed, length;
X char *string, *cmd;
X Tcl_Interp *interp;
X int result;
X
X /*
X * Copy the strings one after the other into a single larger
X * string. Use stack-allocated space for small commands, but if
X * the commands gets too large than call ckalloc to create the
X * space.
X */
X
X va_start(argList);
X interp = va_arg(argList, Tcl_Interp *);
X spaceAvl = FIXED_SIZE;
X spaceUsed = 0;
X cmd = fixedSpace;
X while (1) {
X string = va_arg(argList, char *);
X if (string == NULL) {
X break;
X }
X length = strlen(string);
X if ((spaceUsed + length) > spaceAvl) {
X char *new;
X
X spaceAvl = spaceUsed + length;
X spaceAvl += spaceAvl/2;
X new = ckalloc((unsigned) spaceAvl);
X memcpy((VOID *) new, (VOID *) cmd, spaceUsed);
X if (cmd != fixedSpace) {
X ckfree(cmd);
X }
X cmd = new;
X }
X strcpy(cmd + spaceUsed, string);
X spaceUsed += length;
X }
X va_end(argList);
X cmd[spaceUsed] = '\0';
X

X result = Tcl_Eval(interp, cmd, 0, (char **) NULL);

X if (cmd != fixedSpace) {
X ckfree(cmd);

X }
X return result;
X}

END_OF_FILE
if test 27576 -ne `wc -c <'tcl6.1/tclBasic.c'`; then
echo shar: \"'tcl6.1/tclBasic.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclBasic.c'
fi
echo shar: End of archive 17 $of 33$.
cp /dev/null ark17isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:48:47 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 86
Archive-name: tcl/part18
Environment: UNIX

# "End of archive 18 (of 33)."
# Contents: tcl6.1/regexp.c
# Wrapped by karl@one on Tue Nov 12 19:44:26 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/regexp.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/regexp.c'\"
else
echo shar: Extracting \"'tcl6.1/regexp.c'\" $28040 characters$
sed "s/^X//" >'tcl6.1/regexp.c' <<'END_OF_FILE'
X/*
X * regcomp and regexec -- regsub and regerror are elsewhere
X *
X * Copyright (c) 1986 by University of Toronto.
X * Written by Henry Spencer. Not derived from licensed software.
X *
X * Permission is granted to anyone to use this software for any
X * purpose on any computer system, and to redistribute it freely,
X * subject to the following restrictions:
X *
X * 1. The author is not responsible for the consequences of use of
X * this software, no matter how awful, even if they arise
X * from defects in it.
X *
X * 2. The origin of this software must not be misrepresented, either
X * by explicit claim or by omission.
X *
X * 3. Altered versions must be plainly marked as such, and must not
X * be misrepresented as being the original software.
X *
X * Beware that some of this code is subtly aware of the way operator
X * precedence is structured in regular expressions. Serious changes in
X * regular-expression syntax might require a total rethink.
X *
X * *** NOTE: this code has been altered slightly for use in Tcl. ***
X * *** The only change is to use ckalloc and ckfree instead of ***
X * *** malloc and free. ***
X */
X#include "tclInt.h"
X
X/*
X * The "internal use only" fields in regexp.h are present to pass info from
X * compile to execute that permits the execute phase to run lots faster on
X * simple cases. They are:
X *
X * regstart char that must begin a match; '\0' if none obvious
X * reganch is the match anchored (at beginning-of-line only)?
X * regmust string (pointer into program) that match must include, or NULL
X * regmlen length of regmust string
X *
X * Regstart and reganch permit very fast decisions on suitable starting points
X * for a match, cutting down the work a lot. Regmust permits fast rejection
X * of lines that cannot possibly match. The regmust tests are costly enough
X * that regcomp() supplies a regmust only if the r.e. contains something
X * potentially expensive (at present, the only such thing detected is * or +
X * at the start of the r.e., which can involve a lot of backup). Regmlen is
X * supplied because the test in regexec() needs it and regcomp() is computing
X * it anyway.
X */
X
X/*
X * Structure for regexp "program". This is essentially a linear encoding
X * of a nondeterministic finite-state machine (aka syntax charts or
X * "railroad normal form" in parsing technology). Each node is an opcode
X * plus a "next" pointer, possibly plus an operand. "Next" pointers of
X * all nodes except BRANCH implement concatenation; a "next" pointer with
X * a BRANCH on both ends of it is connecting two alternatives. (Here we
X * have one of the subtle syntax dependencies: an individual BRANCH (as
X * opposed to a collection of them) is never concatenated with anything
X * because of operator precedence.) The operand of some types of node is
X * a literal string; for others, it is a node leading into a sub-FSM. In
X * particular, the operand of a BRANCH node is the first node of the branch.
X * (NB this is *not* a tree structure: the tail of the branch connects
X * to the thing following the set of BRANCHes.) The opcodes are:
X */
X
X/* definition number opnd? meaning */
X#define END 0 /* no End of program. */
X#define BOL 1 /* no Match "" at beginning of line. */
X#define EOL 2 /* no Match "" at end of line. */
X#define ANY 3 /* no Match any one character. */
X#define ANYOF 4 /* str Match any character in this string. */
X#define ANYBUT 5 /* str Match any character not in this string. */
X#define BRANCH 6 /* node Match this alternative, or the next... */
X#define BACK 7 /* no Match "", "next" ptr points backward. */
X#define EXACTLY 8 /* str Match this string. */
X#define NOTHING 9 /* no Match empty string. */
X#define STAR 10 /* node Match this (simple) thing 0 or more times. */
X#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
X#define OPEN 20 /* no Mark this point in input as start of #n. */
X /* OPEN+1 is number 1, etc. */
X#define CLOSE 30 /* no Analogous to OPEN. */
X
X/*
X * Opcode notes:
X *
X * BRANCH The set of branches constituting a single choice are hooked
X * together with their "next" pointers, since precedence prevents
X * anything being concatenated to any individual branch. The
X * "next" pointer of the last BRANCH in a choice points to the
X * thing following the whole choice. This is also where the
X * final "next" pointer of each individual branch points; each
X * branch starts with the operand node of a BRANCH node.
X *
X * BACK Normal "next" pointers all implicitly point forward; BACK
X * exists to make loop structures possible.
X *
X * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
X * BRANCH structures using BACK. Simple cases (one character
X * per match) are implemented with STAR and PLUS for speed
X * and to minimize recursive plunges.
X *
X * OPEN,CLOSE ...are numbered at compile time.
X */
X
X/*
X * A node is one char of opcode followed by two chars of "next" pointer.
X * "Next" pointers are stored as two 8-bit pieces, high order first. The
X * value is a positive offset from the opcode of the node containing it.
X * An operand, if any, simply follows the node. (Note that much of the
X * code generation knows about this implicit relationship.)
X *
X * Using two bytes for the "next" pointer is vast overkill for most things,
X * but allows patterns to get big without disasters.
X */
X#define OP(p) (*(p))
X#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
X#define OPERAND(p) ((p) + 3)
X
X/*
X * See regmagic.h for one further detail of program structure.
X */
X
X
X/*
X * Utility definitions.
X */
X#ifndef CHARBITS
X#define UCHARAT(p) ((int)*(unsigned char *)(p))
X#else
X#define UCHARAT(p) ((int)*(p)&CHARBITS)
X#endif
X
X#define FAIL(m) { regerror(m); return(NULL); }
X#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?')
X#define META "^$.[()|?+*\\"
X
X/*
X * Flags to be passed up and down.
X */
X#define HASWIDTH 01 /* Known never to match null string. */
X#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
X#define SPSTART 04 /* Starts with * or +. */
X#define WORST 0 /* Worst case. */
X
X/*
X * Global work variables for regcomp().
X */
Xstatic char *regparse; /* Input-scan pointer. */
Xstatic int regnpar; /* () count. */
Xstatic char regdummy;
Xstatic char *regcode; /* Code-emit pointer; &regdummy = don't. */
Xstatic long regsize; /* Code size. */
X
X/*
X * The first byte of the regexp internal "program" is actually this magic
X * number; the start node begins in the second byte.
X */
X#define MAGIC 0234
X
X
X/*
X * Forward declarations for regcomp()'s friends.
X */
X#ifndef STATIC
X#define STATIC static
X#endif
XSTATIC char *reg();
XSTATIC char *regbranch();
XSTATIC char *regpiece();
XSTATIC char *regatom();
XSTATIC char *regnode();
XSTATIC char *regnext();
XSTATIC void regc();
XSTATIC void reginsert();
XSTATIC void regtail();
XSTATIC void regoptail();
X#ifdef STRCSPN
XSTATIC int strcspn();
X#endif
X
X/*
X - regcomp - compile a regular expression into internal code
X *
X * We can't allocate space until we know how big the compiled form will be,
X * but we can't compile it (and thus know how big it is) until we've got a
X * place to put the code. So we cheat: we compile it twice, once with code
X * generation turned off and size counting turned on, and once "for real".
X * This also means that we don't allocate space until we are sure that the
X * thing really will compile successfully, and we never have to move the
X * code and thus invalidate pointers into it. (Note that it has to be in
X * one piece because free() must be able to free it all.)
X *
X * Beware that the optimization-preparation code in here knows about some
X * of the structure of the compiled regexp.
X */
Xregexp *
Xregcomp(exp)
Xchar *exp;
X{
X register regexp *r;
X register char *scan;
X register char *longest;
X register int len;
X int flags;
X
X if (exp == NULL)
X FAIL("NULL argument");
X
X /* First pass: determine size, legality. */
X regparse = exp;
X regnpar = 1;
X regsize = 0L;
X regcode = &regdummy;
X regc(MAGIC);
X if (reg(0, &flags) == NULL)
X return(NULL);
X
X /* Small enough for pointer-storage convention? */
X if (regsize >= 32767L) /* Probably could be 65535L. */
X FAIL("regexp too big");
X
X /* Allocate space. */
X r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)regsize);
X if (r == NULL)
X FAIL("out of space");
X
X /* Second pass: emit code. */
X regparse = exp;
X regnpar = 1;
X regcode = r->program;
X regc(MAGIC);
X if (reg(0, &flags) == NULL)
X return(NULL);
X
X /* Dig out information for optimizations. */
X r->regstart = '\0'; /* Worst-case defaults. */
X r->reganch = 0;
X r->regmust = NULL;
X r->regmlen = 0;
X scan = r->program+1; /* First BRANCH. */
X if (OP(regnext(scan)) == END) { /* Only one top-level choice. */
X scan = OPERAND(scan);
X
X /* Starting-point info. */
X if (OP(scan) == EXACTLY)
X r->regstart = *OPERAND(scan);
X else if (OP(scan) == BOL)
X r->reganch++;
X
X /*
X * If there's something expensive in the r.e., find the
X * longest literal string that must appear and make it the
X * regmust. Resolve ties in favor of later strings, since
X * the regstart check works with the beginning of the r.e.
X * and avoiding duplication strengthens checking. Not a
X * strong reason, but sufficient in the absence of others.
X */
X if (flags&SPSTART) {
X longest = NULL;
X len = 0;
X for (; scan != NULL; scan = regnext(scan))
X if (OP(scan) == EXACTLY && strlen(OPERAND(scan)) >= len) {
X longest = OPERAND(scan);
X len = strlen(OPERAND(scan));
X }
X r->regmust = longest;
X r->regmlen = len;
X }
X }
X
X return(r);
X}
X
X/*
X - reg - regular expression, i.e. main body or parenthesized thing
X *
X * Caller must absorb opening parenthesis.
X *
X * Combining parenthesis handling with the base level of regular expression
X * is a trifle forced, but the need to tie the tails of the branches to what
X * follows makes it hard to avoid.
X */
Xstatic char *
Xreg(paren, flagp)
Xint paren; /* Parenthesized? */
Xint *flagp;
X{
X register char *ret;
X register char *br;
X register char *ender;
X register int parno = 0;
X int flags;
X
X *flagp = HASWIDTH; /* Tentatively. */
X
X /* Make an OPEN node, if parenthesized. */
X if (paren) {
X if (regnpar >= NSUBEXP)
X FAIL("too many ()");
X parno = regnpar;
X regnpar++;
X ret = regnode(OPEN+parno);
X } else
X ret = NULL;
X
X /* Pick up the branches, linking them together. */
X br = regbranch(&flags);
X if (br == NULL)
X return(NULL);
X if (ret != NULL)
X regtail(ret, br); /* OPEN -> first. */
X else
X ret = br;
X if (!(flags&HASWIDTH))
X *flagp &= ~HASWIDTH;
X *flagp |= flags&SPSTART;
X while (*regparse == '|') {
X regparse++;
X br = regbranch(&flags);
X if (br == NULL)
X return(NULL);
X regtail(ret, br); /* BRANCH -> BRANCH. */
X if (!(flags&HASWIDTH))
X *flagp &= ~HASWIDTH;
X *flagp |= flags&SPSTART;
X }
X
X /* Make a closing node, and hook it on the end. */
X ender = regnode((paren) ? CLOSE+parno : END);
X regtail(ret, ender);
X
X /* Hook the tails of the branches to the closing node. */
X for (br = ret; br != NULL; br = regnext(br))
X regoptail(br, ender);
X
X /* Check for proper termination. */
X if (paren && *regparse++ != ')') {
X FAIL("unmatched ()");
X } else if (!paren && *regparse != '\0') {
X if (*regparse == ')') {
X FAIL("unmatched ()");
X } else
X FAIL("junk on end"); /* "Can't happen". */
X /* NOTREACHED */
X }
X
X return(ret);
X}
X
X/*
X - regbranch - one alternative of an | operator
X *
X * Implements the concatenation operator.
X */
Xstatic char *
Xregbranch(flagp)
Xint *flagp;
X{
X register char *ret;
X register char *chain;
X register char *latest;
X int flags;
X
X *flagp = WORST; /* Tentatively. */
X
X ret = regnode(BRANCH);
X chain = NULL;
X while (*regparse != '\0' && *regparse != '|' && *regparse != ')') {
X latest = regpiece(&flags);
X if (latest == NULL)
X return(NULL);
X *flagp |= flags&HASWIDTH;
X if (chain == NULL) /* First piece. */
X *flagp |= flags&SPSTART;
X else
X regtail(chain, latest);
X chain = latest;
X }
X if (chain == NULL) /* Loop ran zero times. */
X (void) regnode(NOTHING);
X
X return(ret);
X}
X
X/*
X - regpiece - something followed by possible [*+?]
X *
X * Note that the branching code sequences used for ? and the general cases
X * of * and + are somewhat optimized: they use the same NOTHING node as
X * both the endmarker for their branch list and the body of the last branch.
X * It might seem that this node could be dispensed with entirely, but the
X * endmarker role is not redundant.
X */
Xstatic char *
Xregpiece(flagp)
Xint *flagp;
X{
X register char *ret;
X register char op;
X register char *next;
X int flags;
X
X ret = regatom(&flags);
X if (ret == NULL)
X return(NULL);
X
X op = *regparse;
X if (!ISMULT(op)) {
X *flagp = flags;
X return(ret);
X }
X
X if (!(flags&HASWIDTH) && op != '?')
X FAIL("*+ operand could be empty");
X *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
X
X if (op == '*' && (flags&SIMPLE))
X reginsert(STAR, ret);
X else if (op == '*') {
X /* Emit x* as (x&|), where & means "self". */
X reginsert(BRANCH, ret); /* Either x */
X regoptail(ret, regnode(BACK)); /* and loop */
X regoptail(ret, ret); /* back */
X regtail(ret, regnode(BRANCH)); /* or */
X regtail(ret, regnode(NOTHING)); /* null. */
X } else if (op == '+' && (flags&SIMPLE))
X reginsert(PLUS, ret);
X else if (op == '+') {
X /* Emit x+ as x(&|), where & means "self". */
X next = regnode(BRANCH); /* Either */
X regtail(ret, next);
X regtail(regnode(BACK), ret); /* loop back */
X regtail(next, regnode(BRANCH)); /* or */
X regtail(ret, regnode(NOTHING)); /* null. */
X } else if (op == '?') {
X /* Emit x? as (x|) */
X reginsert(BRANCH, ret); /* Either x */
X regtail(ret, regnode(BRANCH)); /* or */
X next = regnode(NOTHING); /* null. */
X regtail(ret, next);
X regoptail(ret, next);
X }
X regparse++;
X if (ISMULT(*regparse))
X FAIL("nested *?+");
X
X return(ret);
X}
X
X/*
X - regatom - the lowest level
X *
X * Optimization: gobbles an entire sequence of ordinary characters so that
X * it can turn them into a single node, which is smaller to store and
X * faster to run. Backslashed characters are exceptions, each becoming a
X * separate node; the code is simpler that way and it's not worth fixing.
X */
Xstatic char *
Xregatom(flagp)
Xint *flagp;
X{
X register char *ret;
X int flags;
X
X *flagp = WORST; /* Tentatively. */
X
X switch (*regparse++) {
X case '^':
X ret = regnode(BOL);
X break;
X case '$':
X ret = regnode(EOL);
X break;
X case '.':
X ret = regnode(ANY);
X *flagp |= HASWIDTH|SIMPLE;
X break;
X case '[': {
X register int clss;
X register int classend;
X
X if (*regparse == '^') { /* Complement of range. */
X ret = regnode(ANYBUT);
X regparse++;
X } else
X ret = regnode(ANYOF);
X if (*regparse == ']' || *regparse == '-')
X regc(*regparse++);
X while (*regparse != '\0' && *regparse != ']') {
X if (*regparse == '-') {
X regparse++;
X if (*regparse == ']' || *regparse == '\0')
X regc('-');
X else {
X clss = UCHARAT(regparse-2)+1;
X classend = UCHARAT(regparse);
X if (clss > classend+1)
X FAIL("invalid [] range");
X for (; clss <= classend; clss++)
X regc(clss);
X regparse++;
X }
X } else
X regc(*regparse++);
X }
X regc('\0');
X if (*regparse != ']')
X FAIL("unmatched []");
X regparse++;
X *flagp |= HASWIDTH|SIMPLE;
X }
X break;
X case '(':
X ret = reg(1, &flags);
X if (ret == NULL)
X return(NULL);
X *flagp |= flags&(HASWIDTH|SPSTART);

X break;
X case '\0':

X case '|':
X case ')':
X FAIL("internal urp"); /* Supposed to be caught earlier. */
X /* NOTREACHED */
X break;
X case '?':
X case '+':
X case '*':
X FAIL("?+* follows nothing");
X /* NOTREACHED */
X break;
X case '\\':
X if (*regparse == '\0')
X FAIL("trailing \\");
X ret = regnode(EXACTLY);
X regc(*regparse++);
X regc('\0');
X *flagp |= HASWIDTH|SIMPLE;
X break;
X default: {
X register int len;
X register char ender;
X
X regparse--;
X len = strcspn(regparse, META);
X if (len <= 0)
X FAIL("internal disaster");
X ender = *(regparse+len);
X if (len > 1 && ISMULT(ender))
X len--; /* Back off clear of ?+* operand. */
X *flagp |= HASWIDTH;
X if (len == 1)
X *flagp |= SIMPLE;
X ret = regnode(EXACTLY);
X while (len > 0) {
X regc(*regparse++);
X len--;
X }
X regc('\0');
X }
X break;
X }
X
X return(ret);
X}
X
X/*
X - regnode - emit a node
X */
Xstatic char * /* Location. */
Xregnode(op)
Xchar op;
X{
X register char *ret;
X register char *ptr;
X
X ret = regcode;
X if (ret == &regdummy) {
X regsize += 3;
X return(ret);
X }
X
X ptr = ret;
X *ptr++ = op;
X *ptr++ = '\0'; /* Null "next" pointer. */
X *ptr++ = '\0';
X regcode = ptr;
X
X return(ret);
X}
X
X/*
X - regc - emit (if appropriate) a byte of code
X */
Xstatic void
Xregc(b)
Xchar b;
X{
X if (regcode != &regdummy)
X *regcode++ = b;
X else
X regsize++;
X}
X
X/*
X - reginsert - insert an operator in front of already-emitted operand
X *
X * Means relocating the operand.
X */
Xstatic void
Xreginsert(op, opnd)
Xchar op;
Xchar *opnd;

X{
X register char *src;

X register char *dst;
X register char *place;
X
X if (regcode == &regdummy) {
X regsize += 3;
X return;
X }
X
X src = regcode;
X regcode += 3;
X dst = regcode;
X while (src > opnd)
X *--dst = *--src;
X
X place = opnd; /* Op node, where operand used to be. */
X *place++ = op;
X *place++ = '\0';
X *place++ = '\0';
X}
X
X/*
X - regtail - set the next-pointer at the end of a node chain
X */
Xstatic void
Xregtail(p, val)
Xchar *p;
Xchar *val;
X{
X register char *scan;
X register char *temp;
X register int offset;
X
X if (p == &regdummy)
X return;
X
X /* Find last node. */
X scan = p;
X for (;;) {
X temp = regnext(scan);
X if (temp == NULL)
X break;
X scan = temp;
X }
X
X if (OP(scan) == BACK)
X offset = scan - val;
X else
X offset = val - scan;
X *(scan+1) = (offset>>8)&0377;
X *(scan+2) = offset&0377;
X}
X
X/*
X - regoptail - regtail on operand of first argument; nop if operandless
X */
Xstatic void
Xregoptail(p, val)
Xchar *p;
Xchar *val;
X{
X /* "Operandless" and "op != BRANCH" are synonymous in practice. */
X if (p == NULL || p == &regdummy || OP(p) != BRANCH)
X return;
X regtail(OPERAND(p), val);
X}
X
X/*
X * regexec and friends
X */
X
X/*
X * Global work variables for regexec().
X */
Xstatic char *reginput; /* String-input pointer. */
Xstatic char *regbol; /* Beginning of input, for ^ check. */
Xstatic char **regstartp; /* Pointer to startp array. */
Xstatic char **regendp; /* Ditto for endp. */
X
X/*
X * Forwards.
X */
XSTATIC int regtry();
XSTATIC int regmatch();
XSTATIC int regrepeat();
X
X#ifdef DEBUG
Xint regnarrate = 0;
Xvoid regdump();
XSTATIC char *regprop();
X#endif
X
X/*
X - regexec - match a regexp against a string
X */
Xint
Xregexec(prog, string)
Xregister regexp *prog;
Xregister char *string;
X{
X register char *s;
X extern char *strchr();
X
X /* Be paranoid... */
X if (prog == NULL || string == NULL) {
X regerror("NULL parameter");
X return(0);
X }
X
X /* Check validity of program. */
X if (UCHARAT(prog->program) != MAGIC) {
X regerror("corrupted program");
X return(0);
X }
X
X /* If there is a "must appear" string, look for it. */
X if (prog->regmust != NULL) {
X s = string;
X while ((s = strchr(s, prog->regmust[0])) != NULL) {
X if (strncmp(s, prog->regmust, prog->regmlen) == 0)
X break; /* Found it. */
X s++;
X }
X if (s == NULL) /* Not present. */
X return(0);
X }
X
X /* Mark beginning of line for ^ . */
X regbol = string;
X
X /* Simplest case: anchored match need be tried only once. */
X if (prog->reganch)
X return(regtry(prog, string));
X
X /* Messy cases: unanchored match. */
X s = string;
X if (prog->regstart != '\0')
X /* We know what char it must start with. */
X while ((s = strchr(s, prog->regstart)) != NULL) {
X if (regtry(prog, s))
X return(1);
X s++;
X }
X else
X /* We don't -- general case. */
X do {
X if (regtry(prog, s))
X return(1);
X } while (*s++ != '\0');
X
X /* Failure. */
X return(0);
X}
X
X/*
X - regtry - try match at specific point
X */
Xstatic int /* 0 failure, 1 success */
Xregtry(prog, string)
Xregexp *prog;
Xchar *string;
X{
X register int i;
X register char **sp;
X register char **ep;
X
X reginput = string;
X regstartp = prog->startp;
X regendp = prog->endp;
X
X sp = prog->startp;
X ep = prog->endp;
X for (i = NSUBEXP; i > 0; i--) {
X *sp++ = NULL;
X *ep++ = NULL;
X }
X if (regmatch(prog->program + 1)) {
X prog->startp[0] = string;
X prog->endp[0] = reginput;
X return(1);
X } else
X return(0);
X}
X
X/*
X - regmatch - main matching routine
X *
X * Conceptually the strategy is simple: check to see whether the current
X * node matches, call self recursively to see whether the rest matches,
X * and then act accordingly. In practice we make some effort to avoid
X * recursion, in particular by going through "ordinary" nodes (that don't
X * need to know whether the rest of the match failed) by a loop instead of
X * by recursion.
X */
Xstatic int /* 0 failure, 1 success */
Xregmatch(prog)
Xchar *prog;
X{
X register char *scan; /* Current node. */
X char *next; /* Next node. */
X extern char *strchr();
X
X scan = prog;
X#ifdef DEBUG
X if (scan != NULL && regnarrate)
X fprintf(stderr, "%s(\n", regprop(scan));
X#endif
X while (scan != NULL) {
X#ifdef DEBUG
X if (regnarrate)
X fprintf(stderr, "%s...\n", regprop(scan));
X#endif
X next = regnext(scan);
X
X switch (OP(scan)) {
X case BOL:
X if (reginput != regbol)
X return(0);
X break;
X case EOL:
X if (*reginput != '\0')
X return(0);
X break;
X case ANY:
X if (*reginput == '\0')
X return(0);
X reginput++;
X break;
X case EXACTLY: {
X register int len;
X register char *opnd;
X
X opnd = OPERAND(scan);
X /* Inline the first character, for speed. */
X if (*opnd != *reginput)
X return(0);
X len = strlen(opnd);
X if (len > 1 && strncmp(opnd, reginput, len) != 0)
X return(0);
X reginput += len;
X }
X break;
X case ANYOF:
X if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) == NULL)
X return(0);
X reginput++;
X break;
X case ANYBUT:
X if (*reginput == '\0' || strchr(OPERAND(scan), *reginput) != NULL)
X return(0);
X reginput++;
X break;
X case NOTHING:
X break;
X case BACK:
X break;
X case OPEN+1:
X case OPEN+2:
X case OPEN+3:
X case OPEN+4:
X case OPEN+5:
X case OPEN+6:
X case OPEN+7:
X case OPEN+8:
X case OPEN+9: {
X register int no;
X register char *save;
X
X no = OP(scan) - OPEN;
X save = reginput;
X
X if (regmatch(next)) {
X /*
X * Don't set startp if some later
X * invocation of the same parentheses
X * already has.
X */
X if (regstartp[no] == NULL)
X regstartp[no] = save;
X return(1);
X } else
X return(0);
X }
X /* NOTREACHED */
X break;
X case CLOSE+1:
X case CLOSE+2:
X case CLOSE+3:
X case CLOSE+4:
X case CLOSE+5:
X case CLOSE+6:
X case CLOSE+7:
X case CLOSE+8:
X case CLOSE+9: {
X register int no;
X register char *save;
X
X no = OP(scan) - CLOSE;
X save = reginput;
X
X if (regmatch(next)) {
X /*
X * Don't set endp if some later
X * invocation of the same parentheses
X * already has.
X */
X if (regendp[no] == NULL)
X regendp[no] = save;
X return(1);
X } else
X return(0);
X }
X /* NOTREACHED */
X break;
X case BRANCH: {
X register char *save;
X
X if (OP(next) != BRANCH) /* No choice. */
X next = OPERAND(scan); /* Avoid recursion. */
X else {
X do {
X save = reginput;
X if (regmatch(OPERAND(scan)))
X return(1);
X reginput = save;
X scan = regnext(scan);
X } while (scan != NULL && OP(scan) == BRANCH);
X return(0);
X /* NOTREACHED */
X }
X }
X /* NOTREACHED */
X break;
X case STAR:
X case PLUS: {
X register char nextch;
X register int no;
X register char *save;
X register int min;
X
X /*
X * Lookahead to avoid useless match attempts
X * when we know what character comes next.
X */
X nextch = '\0';
X if (OP(next) == EXACTLY)
X nextch = *OPERAND(next);
X min = (OP(scan) == STAR) ? 0 : 1;
X save = reginput;
X no = regrepeat(OPERAND(scan));
X while (no >= min) {
X /* If it could work, try it. */
X if (nextch == '\0' || *reginput == nextch)
X if (regmatch(next))
X return(1);
X /* Couldn't or didn't -- back up. */
X no--;
X reginput = save + no;
X }
X return(0);
X }
X /* NOTREACHED */
X break;
X case END:
X return(1); /* Success! */
X /* NOTREACHED */
X break;
X default:
X regerror("memory corruption");
X return(0);
X /* NOTREACHED */
X break;
X }
X
X scan = next;
X }
X
X /*
X * We get here only if there's trouble -- normally "case END" is
X * the terminating point.
X */
X regerror("corrupted pointers");
X return(0);
X}
X
X/*
X - regrepeat - repeatedly match something simple, report how many
X */
Xstatic int
Xregrepeat(p)
Xchar *p;
X{
X register int count = 0;
X register char *scan;
X register char *opnd;
X
X scan = reginput;
X opnd = OPERAND(p);
X switch (OP(p)) {
X case ANY:
X count = strlen(scan);
X scan += count;
X break;
X case EXACTLY:
X while (*opnd == *scan) {
X count++;
X scan++;
X }
X break;
X case ANYOF:
X while (*scan != '\0' && strchr(opnd, *scan) != NULL) {
X count++;
X scan++;
X }
X break;
X case ANYBUT:
X while (*scan != '\0' && strchr(opnd, *scan) == NULL) {
X count++;
X scan++;
X }
X break;
X default: /* Oh dear. Called inappropriately. */
X regerror("internal foulup");
X count = 0; /* Best compromise. */
X break;
X }
X reginput = scan;
X
X return(count);
X}
X
X/*
X - regnext - dig the "next" pointer out of a node
X */
Xstatic char *
Xregnext(p)
Xregister char *p;
X{
X register int offset;
X
X if (p == &regdummy)
X return(NULL);
X
X offset = NEXT(p);
X if (offset == 0)
X return(NULL);
X
X if (OP(p) == BACK)
X return(p-offset);
X else
X return(p+offset);
X}
X
X#ifdef DEBUG
X
XSTATIC char *regprop();
X
X/*
X - regdump - dump a regexp onto stdout in vaguely comprehensible form
X */
Xvoid
Xregdump(r)
Xregexp *r;
X{
X register char *s;
X register char op = EXACTLY; /* Arbitrary non-END op. */
X register char *next;
X extern char *strchr();
X
X
X s = r->program + 1;
X while (op != END) { /* While that wasn't END last time... */
X op = OP(s);
X printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */
X next = regnext(s);
X if (next == NULL) /* Next ptr. */
X printf("(0)");
X else
X printf("(%d)", (s-r->program)+(next-s));
X s += 3;
X if (op == ANYOF || op == ANYBUT || op == EXACTLY) {
X /* Literal string, where present. */
X while (*s != '\0') {
X putchar(*s);
X s++;
X }
X s++;
X }
X putchar('\n');
X }
X
X /* Header fields of interest. */
X if (r->regstart != '\0')
X printf("start `%c' ", r->regstart);
X if (r->reganch)
X printf("anchored ");
X if (r->regmust != NULL)
X printf("must have \"%s\"", r->regmust);
X printf("\n");
X}
X
X/*
X - regprop - printable representation of opcode
X */
Xstatic char *
Xregprop(op)
Xchar *op;
X{
X register char *p;
X static char buf[50];
X
X (void) strcpy(buf, ":");
X
X switch (OP(op)) {
X case BOL:
X p = "BOL";
X break;
X case EOL:
X p = "EOL";
X break;
X case ANY:
X p = "ANY";
X break;
X case ANYOF:
X p = "ANYOF";
X break;
X case ANYBUT:
X p = "ANYBUT";
X break;
X case BRANCH:
X p = "BRANCH";
X break;
X case EXACTLY:
X p = "EXACTLY";
X break;
X case NOTHING:
X p = "NOTHING";
X break;
X case BACK:
X p = "BACK";
X break;
X case END:
X p = "END";
X break;
X case OPEN+1:
X case OPEN+2:
X case OPEN+3:
X case OPEN+4:
X case OPEN+5:
X case OPEN+6:
X case OPEN+7:
X case OPEN+8:
X case OPEN+9:
X sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
X p = NULL;
X break;
X case CLOSE+1:
X case CLOSE+2:
X case CLOSE+3:
X case CLOSE+4:
X case CLOSE+5:
X case CLOSE+6:
X case CLOSE+7:
X case CLOSE+8:
X case CLOSE+9:
X sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
X p = NULL;
X break;
X case STAR:
X p = "STAR";
X break;
X case PLUS:
X p = "PLUS";
X break;
X default:
X regerror("corrupted opcode");
X break;
X }
X if (p != NULL)
X (void) strcat(buf, p);
X return(buf);
X}
X#endif
X
X/*
X * The following is provided for those people who do not have strcspn() in
X * their C libraries. They should get off their butts and do something
X * about it; at least one public-domain implementation of those (highly
X * useful) string routines has been published on Usenet.
X */
X#ifdef STRCSPN
X/*
X * strcspn - find length of initial segment of s1 consisting entirely
X * of characters not from s2

X */
X
Xstatic int

Xstrcspn(s1, s2)
Xchar *s1;
Xchar *s2;
X{
X register char *scan1;
X register char *scan2;
X register int count;
X
X count = 0;
X for (scan1 = s1; *scan1 != '\0'; scan1++) {
X for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */
X if (*scan1 == *scan2++)
X return(count);
X count++;
X }
X return(count);
X}
X#endif
END_OF_FILE
if test 28040 -ne `wc -c <'tcl6.1/regexp.c'`; then
echo shar: \"'tcl6.1/regexp.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/regexp.c'
fi
echo shar: End of archive 18 $of 33$.
cp /dev/null ark18isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:49:04 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 87
Archive-name: tcl/part19
Environment: UNIX

# "End of archive 19 (of 33)."
# Contents: tcl6.1/tclUnixUtil.c
# Wrapped by karl@one on Tue Nov 12 19:44:27 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclUnixUtil.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclUnixUtil.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUnixUtil.c'\" $28034 characters$
sed "s/^X//" >'tcl6.1/tclUnixUtil.c' <<'END_OF_FILE'
X/*
X * tclUnixUtil.c --
X *
X * This file contains a collection of utility procedures that
X * are present in the Tcl's UNIX core but not in the generic
X * core. For example, they do file manipulation and process
X * manipulation.
X *
X * The Tcl_Fork and Tcl_WaitPids procedures are based on code
X * contributed by Karl Lehenbauer, Mark Diekhans and Peter
X * da Silva.

Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixUtil.c,v 1.17 91/10/10 11:26:25 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X#include "tclUnix.h"
X
X/*

X * Data structures of the following type are used by Tcl_Fork and
X * Tcl_WaitPids to keep track of child processes.
X */
X
Xtypedef struct {
X int pid; /* Process id of child. */
X WAIT_STATUS_TYPE status; /* Status returned when child exited or
X * suspended. */
X int flags; /* Various flag bits; see below for
X * definitions. */
X} WaitInfo;
X
X/*
X * Flag bits in WaitInfo structures:
X *
X * WI_READY - Non-zero means process has exited or
X * suspended since it was forked or last
X * returned by Tcl_WaitPids.
X * WI_DETACHED - Non-zero means no-one cares about the
X * process anymore. Ignore it until it
X * exits, then forget about it.
X */
X
X#define WI_READY 1
X#define WI_DETACHED 2
X
Xstatic WaitInfo *waitTable = NULL;
Xstatic int waitTableSize = 0; /* Total number of entries available in
X * waitTable. */
Xstatic int waitTableUsed = 0; /* Number of entries in waitTable that
X * are actually in use right now. Active
X * entries are always at the beginning
X * of the table. */
X#define WAIT_TABLE_GROW_BY 4

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_EvalFile --
X *
X * Read in a file and process the entire file as one gigantic
X * Tcl command.

X *
X * Results:

X * A standard Tcl result, which is either the result of executing
X * the file or an error indicating why the file couldn't be read.

X *
X * Side effects:

X * Depends on the commands in the file.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_EvalFile(interp, fileName)
X Tcl_Interp *interp; /* Interpreter in which to process file. */
X char *fileName; /* Name of file to process. Tilde-substitution
X * will be performed on this name. */
X{
X int fileId, result;
X struct stat statBuf;
X char *cmdBuffer, *end, *oldScriptFile;

X Interp *iPtr = (Interp *) interp;
X

X oldScriptFile = iPtr->scriptFile;
X iPtr->scriptFile = fileName;
X fileName = Tcl_TildeSubst(interp, fileName);
X if (fileName == NULL) {
X goto error;
X }
X fileId = open(fileName, O_RDONLY, 0);
X if (fileId < 0) {
X Tcl_AppendResult(interp, "couldn't read file \"", fileName,
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X if (fstat(fileId, &statBuf) == -1) {
X Tcl_AppendResult(interp, "couldn't stat file \"", fileName,
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X close(fileId);
X goto error;
X }
X cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
X if (read(fileId, cmdBuffer, (int) statBuf.st_size) != statBuf.st_size) {
X Tcl_AppendResult(interp, "error in reading file \"", fileName,
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X close(fileId);
X goto error;
X }
X if (close(fileId) != 0) {
X Tcl_AppendResult(interp, "error closing file \"", fileName,
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
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[200];
X
X /*
X * Record information telling where the error occurred.
X */
X
X sprintf(msg, "\n (file \"%.150s\" line %d)", fileName,

X interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);
X }

X ckfree(cmdBuffer);
X iPtr->scriptFile = oldScriptFile;
X return result;
X
X error:
X iPtr->scriptFile = oldScriptFile;
X return TCL_ERROR;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_Fork --
X *
X * Create a new process using the vfork system call, and keep
X * track of it for "safe" waiting with Tcl_WaitPids.

X *
X * Results:

X * The return value is the value returned by the vfork system
X * call (0 means child, > 0 means parent (value is child id),
X * < 0 means error).

X *
X * Side effects:

X * A new process is created, and an entry is added to an internal
X * table of child processes if the process is created successfully.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_Fork()
X{
X WaitInfo *waitPtr;
X pid_t pid;
X
X /*
X * Disable SIGPIPE signals: if they were allowed, this process
X * might go away unexpectedly if children misbehave. This code
X * can potentially interfere with other application code that
X * expects to handle SIGPIPEs; what's really needed is an
X * arbiter for signals to allow them to be "shared".
X */
X
X if (waitTable == NULL) {
X (void) signal(SIGPIPE, SIG_IGN);
X }
X
X /*
X * Enlarge the wait table if there isn't enough space for a new
X * entry.
X */
X
X if (waitTableUsed == waitTableSize) {
X int newSize;
X WaitInfo *newWaitTable;
X
X newSize = waitTableSize + WAIT_TABLE_GROW_BY;
X newWaitTable = (WaitInfo *) ckalloc((unsigned)
X (newSize * sizeof(WaitInfo)));
X memcpy((VOID *) newWaitTable, (VOID *) waitTable,
X (waitTableSize * sizeof(WaitInfo)));
X if (waitTable != NULL) {
X ckfree((char *) waitTable);
X }
X waitTable = newWaitTable;
X waitTableSize = newSize;
X }
X
X /*
X * Make a new process and enter it into the table if the fork
X * is successful.
X */
X
X waitPtr = &waitTable[waitTableUsed];
X pid = fork();
X if (pid > 0) {
X waitPtr->pid = pid;
X waitPtr->flags = 0;
X waitTableUsed++;
X }
X return pid;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_WaitPids --
X *
X * This procedure is used to wait for one or more processes created
X * by Tcl_Fork to exit or suspend. It records information about
X * all processes that exit or suspend, even those not waited for,
X * so that later waits for them will be able to get the status
X * information.

X *
X * Results:

X * -1 is returned if there is an error in the wait kernel call.
X * Otherwise the pid of an exited/suspended process from *pidPtr
X * is returned and *statusPtr is set to the status value returned
X * by the wait kernel call.

X *
X * Side effects:

X * Doesn't return until one of the pids at *pidPtr exits or suspends.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_WaitPids(numPids, pidPtr, statusPtr)
X int numPids; /* Number of pids to wait on: gives size
X * of array pointed to by pidPtr. */
X int *pidPtr; /* Pids to wait on: return when one of
X * these processes exits or suspends. */
X int *statusPtr; /* Wait status is returned here. */
X{
X int i, count, pid;
X register WaitInfo *waitPtr;
X int anyProcesses;
X WAIT_STATUS_TYPE status;
X
X while (1) {
X /*
X * Scan the table of child processes to see if one of the
X * specified children has already exited or suspended. If so,
X * remove it from the table and return its status.
X */
X
X anyProcesses = 0;
X for (waitPtr = waitTable, count = waitTableUsed;
X count > 0; waitPtr++, count--) {
X for (i = 0; i < numPids; i++) {
X if (pidPtr[i] != waitPtr->pid) {
X continue;
X }
X anyProcesses = 1;
X if (waitPtr->flags & WI_READY) {
X *statusPtr = *((int *) &waitPtr->status);
X pid = waitPtr->pid;
X if (WIFEXITED(waitPtr->status)
X || WIFSIGNALED(waitPtr->status)) {
X *waitPtr = waitTable[waitTableUsed-1];
X waitTableUsed--;
X } else {
X waitPtr->flags &= ~WI_READY;
X }
X return pid;
X }
X }
X }
X
X /*
X * Make sure that the caller at least specified one valid
X * process to wait for.
X */
X
X if (!anyProcesses) {
X errno = ECHILD;
X return -1;
X }
X
X /*
X * Wait for a process to exit or suspend, then update its
X * entry in the table and go back to the beginning of the
X * loop to see if it's one of the desired processes.
X */
X
X pid = wait(&status);
X if (pid < 0) {
X return pid;
X }
X for (waitPtr = waitTable, count = waitTableUsed; ;
X waitPtr++, count--) {

X if (count == 0) {

X panic("Tcl_WaitPids got unknown process");
X break;
X }
X if (pid != waitPtr->pid) {
X continue;
X }
X
X /*
X * If the process has been detached, then ignore anything
X * other than an exit, and drop the entry on exit.
X */
X
X if (waitPtr->flags & WI_DETACHED) {
X if (WIFEXITED(status) || WIFSIGNALED(status)) {
X *waitPtr = waitTable[waitTableUsed-1];
X waitTableUsed--;
X }
X } else {
X waitPtr->status = status;
X waitPtr->flags |= WI_READY;
X }

X break;
X }
X }
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_DetachPids --
X *
X * This procedure is called to indicate that one or more child
X * processes have been placed in background and are no longer
X * cared about. They should be ignored in future calls to
X * Tcl_WaitPids.

X *
X * Results:
X * None.
X *
X * Side effects:

X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_DetachPids(numPids, pidPtr)
X int numPids; /* Number of pids to detach: gives size
X * of array pointed to by pidPtr. */
X int *pidPtr; /* Array of pids to detach: must have
X * been created by Tcl_Fork. */
X{
X register WaitInfo *waitPtr;
X int i, count, pid;
X
X for (i = 0; i < numPids; i++) {
X pid = pidPtr[i];
X for (waitPtr = waitTable, count = waitTableUsed;
X count > 0; waitPtr++, count--) {
X if (pid != waitPtr->pid) {
X continue;
X }
X
X /*
X * If the process has already exited then destroy its
X * table entry now.
X */
X
X if ((waitPtr->flags & WI_READY) && (WIFEXITED(waitPtr->status)
X || WIFSIGNALED(waitPtr->status))) {
X *waitPtr = waitTable[waitTableUsed-1];
X waitTableUsed--;
X } else {
X waitPtr->flags |= WI_DETACHED;
X }
X goto nextPid;
X }
X panic("Tcl_Detach couldn't find process");
X
X nextPid:
X continue;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_CreatePipeline --
X *
X * Given an argc/argv array, instantiate a pipeline of processes
X * as described by the argv.

X *
X * Results:

X * The return value is a count of the number of new processes
X * created, or -1 if an error occurred while creating the pipeline.
X * *pidArrayPtr is filled in with the address of a dynamically
X * allocated array giving the ids of all of the processes. It
X * is up to the caller to free this array when it isn't needed
X * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in
X * with the file id for the input pipe for the pipeline (if any):
X * the caller must eventually close this file. If outPipePtr
X * isn't NULL, then *outPipePtr is filled in with the file id
X * for the output pipe from the pipeline: the caller must close
X * this file. If errFilePtr isn't NULL, then *errFilePtr is filled
X * with a file id that may be used to read error output after the
X * pipeline completes.

X *
X * Side effects:

X * Processes and pipes are created.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
X outPipePtr, errFilePtr)
X Tcl_Interp *interp; /* Interpreter to use for error reporting. */
X int argc; /* Number of entries in argv. */
X char **argv; /* Array of strings describing commands in
X * pipeline plus I/O redirection with <,
X * <<, and >. Argv[argc] must be NULL. */
X int **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with
X * address of array of pids for processes
X * in pipeline (first pid is first process
X * in pipeline). */
X int *inPipePtr; /* If non-NULL, input to the pipeline comes
X * from a pipe (unless overridden by
X * redirection in the command). The file
X * id with which to write to this pipe is
X * stored at *inPipePtr. -1 means command
X * specified its own input source. */
X int *outPipePtr; /* If non-NULL, output to the pipeline goes
X * to a pipe, unless overriden by redirection
X * in the command. The file id with which to
X * read frome this pipe is stored at
X * *outPipePtr. -1 means command specified
X * its own output sink. */
X int *errFilePtr; /* If non-NULL, all stderr output from the
X * pipeline will go to a temporary file
X * created here, and a descriptor to read
X * the file will be left at *errFilePtr.
X * The file will be removed already, so
X * closing this descriptor will be the end
X * of the file. If this is NULL, then
X * all stderr output goes to our stderr. */
X{
X int *pidPtr = NULL; /* Points to malloc-ed array holding all
X * the pids of child processes. */
X int numPids = 0; /* Actual number of processes that exist
X * at *pidPtr right now. */
X int cmdCount; /* Count of number of distinct commands
X * found in argc/argv. */
X char *input = NULL; /* Describes input for pipeline, depending
X * on "inputFile". NULL means take input
X * from stdin/pipe. */
X int inputFile = 0; /* Non-zero means input is name of input
X * file. Zero means input holds actual
X * text to be input to command. */
X char *output = NULL; /* Holds name of output file to pipe to,
X * or NULL if output goes to stdout/pipe. */
X int inputId = -1; /* Readable file id input to current command in
X * pipeline (could be file or pipe). -1
X * means use stdin. */
X int outputId = -1; /* Writable file id for output from current
X * command in pipeline (could be file or pipe).
X * -1 means use stdout. */
X int errorId = -1; /* Writable file id for all standard error
X * output from all commands in pipeline. -1
X * means use stderr. */
X int lastOutputId = -1; /* Write file id for output from last command
X * in pipeline (could be file or pipe).
X * -1 means use stdout. */
X int pipeIds[2]; /* File ids for pipe that's being created. */
X int firstArg, lastArg; /* Indexes of first and last arguments in
X * current command. */
X int lastBar;
X char *execName;
X int i, j, pid;
X
X if (inPipePtr != NULL) {
X *inPipePtr = -1;
X }
X if (outPipePtr != NULL) {
X *outPipePtr = -1;
X }
X if (errFilePtr != NULL) {
X *errFilePtr = -1;
X }
X pipeIds[0] = pipeIds[1] = -1;
X
X /*
X * First, scan through all the arguments to figure out the structure
X * of the pipeline. Count the number of distinct processes (it's the
X * number of "|" arguments). If there are "<", "<<", or ">" arguments
X * then make note of input and output redirection and remove these
X * arguments and the arguments that follow them.
X */
X
X cmdCount = 1;
X lastBar = -1;

X for (i = 0; i < argc; i++) {

X if ((argv[i][0] == '|') && ((argv[i][1] == 0))) {
X if ((i == (lastBar+1)) || (i == (argc-1))) {
X interp->result = "illegal use of | in command";
X return -1;
X }
X lastBar = i;
X cmdCount++;
X continue;
X } else if (argv[i][0] == '<') {
X if (argv[i][1] == 0) {
X input = argv[i+1];
X inputFile = 1;
X } else if ((argv[i][1] == '<') && (argv[i][2] == 0)) {
X input = argv[i+1];
X inputFile = 0;
X } else {
X continue;
X }
X } else if ((argv[i][0] == '>') && (argv[i][1] == 0)) {
X output = argv[i+1];
X } else {
X continue;
X }
X if (i >= (argc-1)) {
X Tcl_AppendResult(interp, "can't specify \"", argv[i],
X "\" as last word in command", (char *) NULL);
X return -1;
X }
X for (j = i+2; j < argc; j++) {
X argv[j-2] = argv[j];
X }
X argc -= 2;
X i--; /* Process new arg from same position. */
X }
X if (argc == 0) {
X interp->result = "didn't specify command to execute";
X return -1;
X }
X
X /*
X * Set up the redirected input source for the pipeline, if
X * so requested.
X */
X
X if (input != NULL) {
X if (!inputFile) {
X /*
X * Immediate data in command. Create temporary file and
X * put data into file.
X */
X
X# define TMP_STDIN_NAME "/tmp/tcl.in.XXXXXX"
X char inName[sizeof(TMP_STDIN_NAME) + 1];
X int length;
X
X strcpy(inName, TMP_STDIN_NAME);
X mktemp(inName);
X inputId = open(inName, O_RDWR|O_CREAT|O_TRUNC, 0600);
X if (inputId < 0) {
X Tcl_AppendResult(interp,
X "couldn't create input file for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X length = strlen(input);
X if (write(inputId, input, length) != length) {
X Tcl_AppendResult(interp,
X "couldn't write file input for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X if ((lseek(inputId, 0L, 0) == -1) || (unlink(inName) == -1)) {
X Tcl_AppendResult(interp,
X "couldn't reset or remove input file for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;

X }
X } else {
X /*

X * File redirection. Just open the file.
X */
X
X inputId = open(input, O_RDONLY, 0);
X if (inputId < 0) {
X Tcl_AppendResult(interp,
X "couldn't read file \"", input, "\": ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X }
X } else if (inPipePtr != NULL) {
X if (pipe(pipeIds) != 0) {
X Tcl_AppendResult(interp,
X "couldn't create input pipe for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X inputId = pipeIds[0];
X *inPipePtr = pipeIds[1];
X pipeIds[0] = pipeIds[1] = -1;
X }
X
X /*
X * Set up the redirected output sink for the pipeline from one
X * of two places, if requested.
X */
X
X if (output != NULL) {
X /*
X * Output is to go to a file.
X */
X
X lastOutputId = open(output, O_WRONLY|O_CREAT|O_TRUNC, 0666);
X if (lastOutputId < 0) {
X Tcl_AppendResult(interp,
X "couldn't write file \"", output, "\": ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X } else if (outPipePtr != NULL) {
X /*
X * Output is to go to a pipe.
X */
X
X if (pipe(pipeIds) != 0) {
X Tcl_AppendResult(interp,
X "couldn't create output pipe: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X lastOutputId = pipeIds[1];
X *outPipePtr = pipeIds[0];
X pipeIds[0] = pipeIds[1] = -1;
X }
X
X /*
X * Set up the standard error output sink for the pipeline, if
X * requested. Use a temporary file which is opened, then deleted.
X * Could potentially just use pipe, but if it filled up it could
X * cause the pipeline to deadlock: we'd be waiting for processes
X * to complete before reading stderr, and processes couldn't complete
X * because stderr was backed up.
X */
X
X if (errFilePtr != NULL) {
X# define TMP_STDERR_NAME "/tmp/tcl.err.XXXXXX"
X char errName[sizeof(TMP_STDERR_NAME) + 1];
X
X strcpy(errName, TMP_STDERR_NAME);
X mktemp(errName);
X errorId = open(errName, O_WRONLY|O_CREAT|O_TRUNC, 0600);
X if (errorId < 0) {
X errFileError:
X Tcl_AppendResult(interp,
X "couldn't create error file for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X *errFilePtr = open(errName, O_RDONLY, 0);
X if (*errFilePtr < 0) {
X goto errFileError;
X }
X if (unlink(errName) == -1) {
X Tcl_AppendResult(interp,
X "couldn't remove error file for command: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X }
X
X /*
X * Scan through the argc array, forking off a process for each
X * group of arguments between "|" arguments.
X */
X
X pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int)));
X for (i = 0; i < numPids; i++) {
X pidPtr[i] = -1;
X }
X for (firstArg = 0; firstArg < argc; numPids++, firstArg = lastArg+1) {
X for (lastArg = firstArg; lastArg < argc; lastArg++) {
X if ((argv[lastArg][0] == '|') && (argv[lastArg][1] == 0)) {
X break;
X }
X }
X argv[lastArg] = NULL;
X if (lastArg == argc) {
X outputId = lastOutputId;
X } else {
X if (pipe(pipeIds) != 0) {
X Tcl_AppendResult(interp, "couldn't create pipe: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X outputId = pipeIds[1];
X }
X execName = Tcl_TildeSubst(interp, argv[firstArg]);
X pid = Tcl_Fork();
X if (pid == -1) {
X Tcl_AppendResult(interp, "couldn't fork child process: ",
X Tcl_UnixError(interp), (char *) NULL);
X goto error;
X }
X if (pid == 0) {
X char errSpace[200];
X
X if (((inputId != -1) && (dup2(inputId, 0) == -1))
X || ((outputId != -1) && (dup2(outputId, 1) == -1))
X || ((errorId != -1) && (dup2(errorId, 2) == -1))) {
X char *err;
X err = "forked process couldn't set up input/output\n";
X write(errorId < 0 ? 2 : errorId, err, strlen(err));
X _exit(1);
X }
X for (i = 3; (i <= outputId) || (i <= inputId) || (i <= errorId);
X i++) {
X close(i);
X }
X execvp(execName, &argv[firstArg]);
X sprintf(errSpace, "couldn't find \"%.150s\" to execute\n",
X argv[firstArg]);
X write(2, errSpace, strlen(errSpace));
X _exit(1);
X } else {
X pidPtr[numPids] = pid;
X }
X
X /*
X * Close off our copies of file descriptors that were set up for
X * this child, then set up the input for the next child.
X */
X
X if (inputId != -1) {
X close(inputId);
X }
X if (outputId != -1) {
X close(outputId);
X }
X inputId = pipeIds[0];
X pipeIds[0] = pipeIds[1] = -1;
X }
X *pidArrayPtr = pidPtr;
X
X /*
X * All done. Cleanup open files lying around and then return.
X */
X
Xcleanup:
X if (inputId != -1) {
X close(inputId);
X }
X if (lastOutputId != -1) {
X close(lastOutputId);
X }
X if (errorId != -1) {
X close(errorId);
X }
X return numPids;
X
X /*
X * An error occurred. There could have been extra files open, such
X * as pipes between children. Clean them all up. Detach any child
X * processes that have been created.
X */
X
X error:
X if ((inPipePtr != NULL) && (*inPipePtr != -1)) {
X close(*inPipePtr);
X *inPipePtr = -1;
X }
X if ((outPipePtr != NULL) && (*outPipePtr != -1)) {
X close(*outPipePtr);
X *outPipePtr = -1;
X }
X if ((errFilePtr != NULL) && (*errFilePtr != -1)) {
X close(*errFilePtr);
X *errFilePtr = -1;
X }
X if (pipeIds[0] != -1) {
X close(pipeIds[0]);
X }
X if (pipeIds[1] != -1) {
X close(pipeIds[1]);
X }
X if (pidPtr != NULL) {
X for (i = 0; i < numPids; i++) {
X if (pidPtr[i] != -1) {
X Tcl_DetachPids(1, &pidPtr[i]);
X }
X }
X ckfree((char *) pidPtr);
X }
X numPids = -1;
X goto cleanup;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UnixError --
X *
X * This procedure is typically called after UNIX kernel calls
X * return errors. It stores machine-readable information about
X * the error in $errorCode returns an information string for
X * the caller's use.

X *
X * Results:

X * The return value is a human-readable string describing the
X * error, as returned by strerror.

X *
X * Side effects:

X * The global variable $errorCode is reset.

X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_UnixError(interp)
X Tcl_Interp *interp; /* Interpreter whose $errorCode variable
X * is to be changed. */
X{
X char *id, *msg;
X
X id = Tcl_ErrnoId();
X msg = strerror(errno);
X Tcl_SetErrorCode(interp, "UNIX", id, msg, (char *) NULL);
X return msg;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * TclMakeFileTable --
X *
X * Create or enlarge the file table for the interpreter, so that
X * there is room for a given index.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The file table for iPtr will be created if it doesn't exist
X * (and entries will be added for stdin, stdout, and stderr).
X * If it already exists, then it will be grown if necessary.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTclMakeFileTable(iPtr, index)
X Interp *iPtr; /* Interpreter whose table of files is
X * to be manipulated. */
X int index; /* Make sure table is large enough to
X * hold at least this index. */
X{
X /*
X * If the table doesn't even exist, then create it and initialize
X * entries for standard files.
X */
X
X if (iPtr->numFiles == 0) {
X OpenFile *filePtr;
X int i;
X
X if (index < 2) {
X iPtr->numFiles = 3;
X } else {
X iPtr->numFiles = index+1;
X }
X iPtr->filePtrArray = (OpenFile **) ckalloc((unsigned)
X ((iPtr->numFiles)*sizeof(OpenFile *)));
X for (i = iPtr->numFiles-1; i >= 0; i--) {
X iPtr->filePtrArray[i] = NULL;
X }
X
X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
X filePtr->f = stdin;
X filePtr->f2 = NULL;
X filePtr->readable = 1;
X filePtr->writable = 0;
X filePtr->numPids = 0;
X filePtr->pidPtr = NULL;
X filePtr->errorId = -1;
X iPtr->filePtrArray[0] = filePtr;
X
X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
X filePtr->f = stdout;
X filePtr->f2 = NULL;
X filePtr->readable = 0;
X filePtr->writable = 1;
X filePtr->numPids = 0;
X filePtr->pidPtr = NULL;
X filePtr->errorId = -1;
X iPtr->filePtrArray[1] = filePtr;
X
X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
X filePtr->f = stderr;
X filePtr->f2 = NULL;
X filePtr->readable = 0;
X filePtr->writable = 1;
X filePtr->numPids = 0;
X filePtr->pidPtr = NULL;
X filePtr->errorId = -1;
X iPtr->filePtrArray[2] = filePtr;
X } else if (index >= iPtr->numFiles) {
X int newSize;
X OpenFile **newPtrArray;
X int i;
X
X newSize = index+1;
X newPtrArray = (OpenFile **) ckalloc((unsigned)
X ((newSize)*sizeof(OpenFile *)));
X memcpy((VOID *) newPtrArray, (VOID *) iPtr->filePtrArray,
X iPtr->numFiles*sizeof(OpenFile *));
X for (i = iPtr->numFiles; i < newSize; i++) {
X newPtrArray[i] = NULL;
X }

X ckfree((char *) iPtr->filePtrArray);

X iPtr->numFiles = newSize;
X iPtr->filePtrArray = newPtrArray;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclGetOpenFile --
X *
X * Given a string identifier for an open file, find the corresponding
X * open file structure, if there is one.

X *
X * Results:

X * A standard Tcl return value. If the open file is successfully
X * located, *filePtrPtr is modified to point to its structure.
X * If TCL_ERROR is returned then interp->result contains an error
X * message.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xint
XTclGetOpenFile(interp, string, filePtrPtr)
X Tcl_Interp *interp; /* Interpreter in which to find file. */
X char *string; /* String that identifies file. */
X OpenFile **filePtrPtr; /* Address of word in which to store pointer
X * to structure about open file. */
X{
X int fd = 0; /* Initial value needed only to stop compiler
X * warnings. */

X Interp *iPtr = (Interp *) interp;
X

X if ((string[0] == 'f') && (string[1] == 'i') && (string[2] == 'l')
X & (string[3] == 'e')) {
X char *end;
X
X fd = strtoul(string+4, &end, 10);
X if ((end == string+4) || (*end != 0)) {
X goto badId;
X }
X } else if ((string[0] == 's') && (string[1] == 't')
X && (string[2] == 'd')) {
X if (strcmp(string+3, "in") == 0) {
X fd = 0;
X } else if (strcmp(string+3, "out") == 0) {
X fd = 1;
X } else if (strcmp(string+3, "err") == 0) {
X fd = 2;
X } else {
X goto badId;
X }
X } else {
X badId:
X Tcl_AppendResult(interp, "bad file identifier \"", string,
X "\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X if (fd >= iPtr->numFiles) {
X if ((iPtr->numFiles == 0) && (fd <= 2)) {
X TclMakeFileTable(iPtr, fd);
X } else {
X notOpen:
X Tcl_AppendResult(interp, "file \"", string, "\" isn't open",
X (char *) NULL);

X return TCL_ERROR;
X }
X }

X if (iPtr->filePtrArray[fd] == NULL) {
X goto notOpen;
X }
X *filePtrPtr = iPtr->filePtrArray[fd];

X return TCL_OK;
X}
END_OF_FILE

if test 28034 -ne `wc -c <'tcl6.1/tclUnixUtil.c'`; then
echo shar: \"'tcl6.1/tclUnixUtil.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUnixUtil.c'
fi
echo shar: End of archive 19 $of 33$.
cp /dev/null ark19isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:49:22 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 88
Archive-name: tcl/part20
Environment: UNIX

# "End of archive 20 (of 33)."
# Contents: tcl6.1/tclCmdIL.c
# Wrapped by karl@one on Tue Nov 12 19:44:27 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclCmdIL.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclCmdIL.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCmdIL.c'\" $29320 characters$
sed "s/^X//" >'tcl6.1/tclCmdIL.c' <<'END_OF_FILE'
X/*
X * tclCmdIL.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 through L. It contains only commands in the generic core
X * (i.e. those that don't depend much upon UNIX facilities).
X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclCmdIL.c,v 1.82 91/10/31 16:41:50 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * Forward declarations for procedures defined in this file:
X */
X
Xstatic int SortCompareProc _ANSI_ARGS_((CONST char *first,
X CONST char *second));

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 char *clause;

X int result, value;
X

X name = argv[0];
X if (argc < 3) {
X ifSyntax:
X Tcl_AppendResult(interp, "wrong # args: should be \"", name,
X " bool ?then? command ?else? ?command?\"", (char *) NULL);
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 clause = "\"then\" clause";
X result = Tcl_ExprBoolean(interp, condition, &value);

X if (result != TCL_OK) {

X if (result == TCL_ERROR) {

X char msg[60];
X sprintf(msg, "\n (\"if\" test line %d)", interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);
X }
X return result;
X }
X if (value == 0) {
X cmd = elsePart;
X clause = "\"else\" clause";
X }
X if (*cmd == 0) {
X return TCL_OK;

X }
X result = Tcl_Eval(interp, cmd, 0, (char **) NULL);

X if (result == TCL_ERROR) {

X char msg[60];
X sprintf(msg, "\n (%s line %d)", clause, interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);
X }
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_IncrCmd --
X *
X * This procedure is invoked to process the "incr" 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_IncrCmd(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 value;
X char *oldString, *result;
X char newString[30];

X
X if ((argc != 2) && (argc != 3)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " varName ?increment?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
X if (oldString == NULL) {
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
X Tcl_AddErrorInfo(interp,
X "\n (reading value of variable to increment)");
X return TCL_ERROR;
X }

X if (argc == 2) {

X value += 1;
X } else {
X int increment;
X
X if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
X Tcl_AddErrorInfo(interp,
X "\n (reading increment)");
X return TCL_ERROR;
X }
X value += increment;
X }
X sprintf(newString, "%d", value);
X result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
X if (result == NULL) {
X return TCL_ERROR;
X }
X interp->result = result;
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 int length;
X char c;
X Arg *argPtr;
X Proc *procPtr;
X Var *varPtr;
X Command *cmdPtr;
X Tcl_HashEntry *hPtr;
X Tcl_HashSearch search;

X
X if (argc < 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " option ?arg arg ...?\"", (char *) NULL);
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 Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " args procname\"", (char *) NULL);
X return TCL_ERROR;
X }
X procPtr = TclFindProc(iPtr, argv[2]);
X if (procPtr == NULL) {
X infoNoSuchProc:
X Tcl_AppendResult(interp, "\"", argv[2],
X "\" isn't a procedure", (char *) NULL);
X return TCL_ERROR;
X }

X for (argPtr = procPtr->argPtr; argPtr != NULL;

X argPtr = argPtr->nextPtr) {
X Tcl_AppendElement(interp, argPtr->name, 0);
X }
X return TCL_OK;
X } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " body procname\"", (char *) NULL);
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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " cmdcount\"", (char *) NULL);
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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " commands [pattern]\"", (char *) NULL);
X return TCL_ERROR;
X }

X for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
X if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X continue;
X }
X Tcl_AppendElement(interp, name, 0);
X }
X return TCL_OK;
X } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {

X if (argc != 5) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " default procname arg varname\"",

X (char *) NULL);
X return TCL_ERROR;
X }

X procPtr = TclFindProc(iPtr, argv[2]);
X if (procPtr == NULL) {
X goto infoNoSuchProc;
X }
X for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
X if (argPtr == NULL) {
X Tcl_AppendResult(interp, "procedure \"", argv[2],
X "\" doesn't have an argument \"", argv[3],

X "\"", (char *) NULL);
X return TCL_ERROR;
X }

X if (strcmp(argv[3], argPtr->name) == 0) {
X if (argPtr->defValue != NULL) {
X if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
X argPtr->defValue, 0) == NULL) {
X defStoreError:
X Tcl_AppendResult(interp,
X "couldn't store default value in variable \"",
X argv[4], "\"", (char *) NULL);
X return TCL_ERROR;
X }
X iPtr->result = "1";
X } else {
X if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
X == NULL) {
X goto defStoreError;
X }
X iPtr->result = "0";
X }
X return TCL_OK;
X }
X }
X } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
X char *p;

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " exists varName\"", (char *) NULL);
X return TCL_ERROR;
X }
X p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
X
X /*
X * The code below handles the special case where the name is for
X * an array: Tcl_GetVar will reject this since you can't read
X * an array variable without an index.
X */
X
X if (p == NULL) {
X Tcl_HashEntry *hPtr;
X Var *varPtr;
X
X if (strchr(argv[2], '(') != NULL) {
X noVar:
X iPtr->result = "0";
X return TCL_OK;
X }

X if (iPtr->varFramePtr == NULL) {

X hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
X } else {
X hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
X }

X if (hPtr == NULL) {

X goto noVar;
X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
X }
X if (!(varPtr->flags & VAR_ARRAY)) {
X goto noVar;
X }
X }
X iPtr->result = "1";
X return TCL_OK;
X } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
X char *name;

X
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " globals [pattern]\"", (char *) NULL);
X return TCL_ERROR;
X }
X for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UNDEFINED) {
X continue;
X }
X name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
X if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X continue;
X }
X Tcl_AppendElement(interp, name, 0);
X }
X return TCL_OK;
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 CallFrame *framePtr;
X
X if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
X return TCL_ERROR;
X }
X if (level <= 0) {

X if (iPtr->varFramePtr == NULL) {

X levelError:
X Tcl_AppendResult(interp, "bad level \"", argv[2],

X "\"", (char *) NULL);
X return TCL_ERROR;
X }

X level += iPtr->varFramePtr->level;
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->freeProc = (Tcl_FreeProc *) free;
X return TCL_OK;
X }

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " level [number]\"", (char *) NULL);
X return TCL_ERROR;
X } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
X && (length >= 2)) {

X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " library\"", (char *) NULL);
X return TCL_ERROR;
X }
X#ifdef TCL_LIBRARY
X interp->result = TCL_LIBRARY;
X return TCL_OK;
X#else
X interp->result = "there is no Tcl library at this installation";
X return TCL_ERROR;
X#endif
X } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
X && (length >= 2)) {
X char *name;

X
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " locals [pattern]\"", (char *) NULL);
X return TCL_ERROR;
X }

X if (iPtr->varFramePtr == NULL) {

X return TCL_OK;
X }
X for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
X continue;
X }
X name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
X if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X continue;
X }
X Tcl_AppendElement(interp, name, 0);
X }
X return TCL_OK;
X } else if ((c == 'p') && (strncmp(argv[1], "procs", length)) == 0) {
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " procs [pattern]\"", (char *) NULL);
X return TCL_ERROR;
X }

X for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);

X
X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X if (!TclIsProc(cmdPtr)) {
X continue;
X }
X if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X continue;
X }
X Tcl_AppendElement(interp, name, 0);
X }
X return TCL_OK;
X } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {

X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " script\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (iPtr->scriptFile != NULL) {
X interp->result = iPtr->scriptFile;
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {

X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " tclversion\"", (char *) NULL);

X return TCL_ERROR;
X }
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 Tcl_HashTable *tablePtr;
X char *name;

X
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",
X argv[0], " vars [pattern]\"", (char *) NULL);
X return TCL_ERROR;
X }

X if (iPtr->varFramePtr == NULL) {

X tablePtr = &iPtr->globalTable;
X } else {
X tablePtr = &iPtr->varFramePtr->varTable;
X }
X for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UNDEFINED) {
X continue;
X }
X name = Tcl_GetHashKey(tablePtr, hPtr);
X if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
X continue;
X }
X Tcl_AppendElement(interp, name, 0);
X }
X return TCL_OK;
X } else {

X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": should be args, body, commands, cmdcount, default, ",
X "exists, globals, level, library, locals, procs, ",
X "script, tclversion, or vars",

X (char *) NULL);
X return TCL_ERROR;

X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_JoinCmd --
X *
X * This procedure is invoked to process the "join" 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_JoinCmd(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 *joinString;
X char **listArgv;
X int listArgc, i;
X
X if (argc == 2) {
X joinString = " ";
X } else if (argc == 3) {
X joinString = argv[2];
X } else {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list ?joinString?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X return TCL_ERROR;
X }
X for (i = 0; i < listArgc; i++) {
X if (i == 0) {
X Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
X } else {
X Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
X }

X }
X ckfree((char *) listArgv);

X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LindexCmd --
X *
X * This procedure is invoked to process the "lindex" 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_LindexCmd(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 index, size, parenthesized, result;
X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list index\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
X return TCL_ERROR;
X }
X if (index < 0) {
X return TCL_OK;
X }
X for (p = argv[1] ; index >= 0; index--) {
X result = TclFindElement(interp, p, &element, &p, &size,
X &parenthesized);

X if (result != TCL_OK) {

X return result;
X }
X }

X if (size == 0) {
X return TCL_OK;
X }
X if (size >= TCL_RESULT_SIZE) {
X interp->result = (char *) ckalloc((unsigned) size+1);

X interp->freeProc = (Tcl_FreeProc *) free;
X }

X if (parenthesized) {
X memcpy((VOID *) interp->result, (VOID *) element, size);
X interp->result[size] = 0;
X } else {
X TclCopyAndCollapse(size, element, interp->result);

X }
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LinsertCmd --
X *
X * This procedure is invoked to process the "linsert" 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_LinsertCmd(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, savedChar;
X int i, index, count, result, size, brace;
X
X if (argc < 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list index element ?element ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {

X return TCL_ERROR;
X }
X

X /*
X * Skip over the first "index" elements of the list, then add
X * all of those elements to the result.
X */
X
X size = 0;
X brace = 0;
X element = argv[1];
X for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
X result = TclFindElement(interp, p, &element, &p, &size, &brace);

X if (result != TCL_OK) {

X return result;
X }
X }

X if (*p == 0) {

X Tcl_AppendResult(interp, argv[1], (char *) NULL);
X } else {
X char *end;
X
X end = element+size;
X if (brace) {
X end++;
X }
X savedChar = *end;
X *end = 0;
X Tcl_AppendResult(interp, argv[1], (char *) NULL);
X *end = savedChar;
X }
X
X /*
X * Add the new list elements.
X */
X
X for (i = 3; i < argc; i++) {
X Tcl_AppendElement(interp, argv[i], 0);
X }
X
X /*
X * Append the remainder of the original list.
X */
X
X if (*p != 0) {
X Tcl_AppendResult(interp, " ", p, (char *) NULL);

X }
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 if (argc < 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " arg ?arg ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X interp->result = Tcl_Merge(argc-1, argv+1);

X interp->freeProc = (Tcl_FreeProc *) free;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LlengthCmd --
X *
X * This procedure is invoked to process the "llength" 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_LlengthCmd(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, result;
X char *element, *p;

X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list\"", (char *) NULL);
X return TCL_ERROR;
X }
X for (count = 0, p = argv[1]; *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 sprintf(interp->result, "%d", count);
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LrangeCmd --
X *
X * This procedure is invoked to process the "lrange" 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_LrangeCmd(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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list first last\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
X return TCL_ERROR;
X }
X if (first < 0) {
X first = 0;
X }
X if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
X last = 1000000;
X } else {
X if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp,
X "expected integer or \"end\" but got \"",
X argv[3], "\"", (char *) NULL);

X return TCL_ERROR;
X }
X }

X if (first > last) {
X return TCL_OK;
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 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 c = *end;
X *end = 0;
X Tcl_SetResult(interp, begin, TCL_VOLATILE);
X *end = c;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LreplaceCmd --
X *
X * This procedure is invoked to process the "lreplace" 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_LreplaceCmd(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 char *p1, *p2, *element, savedChar, *dummy;
X int i, first, last, count, result, size, brace;
X
X if (argc < 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list first last ?element element ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
X return TCL_ERROR;
X }
X if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
X return TCL_ERROR;
X }
X if (first < 0) {
X first = 0;
X }
X if (last < 0) {
X last = 0;
X }
X if (first > last) {
X Tcl_AppendResult(interp, "first index must not be greater than second",

X (char *) NULL);
X return TCL_ERROR;
X }
X

X /*
X * Skip over the elements of the list before "first".
X */
X
X size = 0;
X brace = 0;
X element = argv[1];
X for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
X result = TclFindElement(interp, p1, &element, &p1, &size, &brace);

X if (result != TCL_OK) {

X return result;
X }
X }

X if (*p1 == 0) {
X Tcl_AppendResult(interp, "list doesn't contain element ",
X argv[2], (char *) NULL);

X return TCL_ERROR;
X }
X

X /*
X * Skip over the elements of the list up through "last".
X */
X
X for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
X result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
X (int *) NULL);

X if (result != TCL_OK) {

X return result;
X }
X }

X
X /*
X * Add the elements up through "first" to the result.
X */
X
X p1 = element+size;
X if (brace) {
X p1++;
X }
X savedChar = *p1;
X *p1 = 0;
X Tcl_AppendResult(interp, argv[1], (char *) NULL);
X *p1 = savedChar;
X
X /*
X * Add the new list elements.
X */
X
X for (i = 4; i < argc; i++) {
X Tcl_AppendElement(interp, argv[i], 0);
X }
X
X /*
X * Append the remainder of the original list.
X */
X
X if (*p2 != 0) {
X if (*interp->result == 0) {
X Tcl_SetResult(interp, p2, TCL_VOLATILE);
X } else {
X Tcl_AppendResult(interp, " ", p2, (char *) NULL);
X }

X }
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LsearchCmd --
X *
X * This procedure is invoked to process the "lsearch" 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_LsearchCmd(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 listArgc;
X char **listArgv;
X int i, match;
X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list pattern\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X return TCL_ERROR;
X }
X match = -1;
X for (i = 0; i < listArgc; i++) {
X if (Tcl_StringMatch(listArgv[i], argv[2])) {
X match = i;
X break;
X }
X }
X sprintf(interp->result, "%d", match);
X ckfree((char *) listArgv);
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LsortCmd --
X *
X * This procedure is invoked to process the "lsort" 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_LsortCmd(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 listArgc;
X char **listArgv;
X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " list\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
X return TCL_ERROR;
X }
X qsort((char *) listArgv, listArgc, sizeof (char *), SortCompareProc);
X interp->result = Tcl_Merge(listArgc, listArgv);

X interp->freeProc = (Tcl_FreeProc *) free;

X ckfree((char *) listArgv);
X return TCL_OK;
X}
X
X/*
X * The procedure below is called back by qsort to determine
X * the proper ordering between two elements.

X */
X
Xstatic int

XSortCompareProc(first, second)
X CONST char *first, *second; /* Elements to be compared. */
X{
X return strcmp(*((char **) first), *((char **) second));
X}
END_OF_FILE
if test 29320 -ne `wc -c <'tcl6.1/tclCmdIL.c'`; then
echo shar: \"'tcl6.1/tclCmdIL.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCmdIL.c'
fi
echo shar: End of archive 20 $of 33$.
cp /dev/null ark20isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:50:08 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 89
Archive-name: tcl/part21
Environment: UNIX

# "End of archive 21 (of 33)."
# Contents: tcl6.1/tclHistory.c
# Wrapped by karl@one on Tue Nov 12 19:44:28 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclHistory.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclHistory.c'\"
else
echo shar: Extracting \"'tcl6.1/tclHistory.c'\" $30514 characters$
sed "s/^X//" >'tcl6.1/tclHistory.c' <<'END_OF_FILE'
X/*
X * tclHistory.c --
X *
X * This module implements history as an optional addition to Tcl.
X * It can be called to record commands ("events") before they are
X * executed, and it provides a command that may be used to perform
X * history substitutions.
X *
X * Copyright 1990-1991 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: /user6/ouster/tcl/RCS/tclHistory.c,v 1.23 91/10/28 09:11:16 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X

X#include "tclInt.h"
X
X/*
X * This history stuff is mostly straightforward, except for one thing
X * that makes everything very complicated. Suppose that the following
X * commands get executed:
X * echo foo
X * history redo
X * It's important that the history event recorded for the second command
X * be "echo foo", not "history redo". Otherwise, if another "history redo"
X * command is typed, it will result in infinite recursions on the
X * "history redo" command. Thus, the actual recorded history must be
X * echo foo
X * echo foo
X * To do this, the history command revises recorded history as part of
X * its execution. In the example above, when "history redo" starts
X * execution, the current event is "history redo", but the history
X * command arranges for the current event to be changed to "echo foo".
X *
X * There are three additional complications. The first is that history
X * substitution may only be part of a command, as in the following
X * command sequence:
X * echo foo bar
X * echo [history word 3]
X * In this case, the second event should be recorded as "echo bar". Only
X * part of the recorded event is to be modified. Fortunately, Tcl_Eval
X * helps with this by recording (in the evalFirst and evalLast fields of
X * the intepreter) the location of the command being executed, so the
X * history module can replace exactly the range of bytes corresponding
X * to the history substitution command.
X *
X * The second complication is that there are two ways to revise history:
X * replace a command, and replace the result of a command. Consider the
X * two examples below:
X * format {result is %d} $num | format {result is %d} $num
X * print [history redo] | print [history word 3]
X * Recorded history for these two cases should be as follows:
X * format {result is %d} $num | format {result is %d} $num
X * print [format {result is %d} $num] | print $num
X * In the left case, the history command was replaced with another command
X * to be executed (the brackets were retained), but in the case on the
X * right the result of executing the history command was replaced (i.e.
X * brackets were replaced too).
X *
X * The third complication is that there could potentially be many
X * history substitutions within a single command, as in:
X * echo [history word 3] [history word 2]
X * There could even be nested history substitutions, as in:
X * history subs abc [history word 2]
X * If history revisions were made immediately during each "history" command
X * invocations, it would be very difficult to produce the correct cumulative
X * effect from several substitutions in the same command. To get around
X * this problem, the actual history revision isn't made during the execution
X * of the "history" command. Information about the changes is just recorded,
X * in xxx records, and the actual changes are made during the next call to
X * Tcl_RecordHistory (when we know that execution of the previous command
X * has finished).
X */
X
X/*
X * Default space allocation for command strings:
X */
X
X#define INITIAL_CMD_SIZE 40
X
X/*
X * Forward declarations for procedures defined later in this file:
X */
X
Xstatic void DoRevs _ANSI_ARGS_((Interp *iPtr));
Xstatic HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string));
Xstatic char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command,
X char *words));
Xstatic void InsertRev _ANSI_ARGS_((Interp *iPtr,
X HistoryRev *revPtr));
Xstatic void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size));
Xstatic void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string));
Xstatic void RevResult _ANSI_ARGS_((Interp *iPtr, char *string));
Xstatic int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd,
X char *old, char *new));

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_InitHistory --
X *
X * Initialize history-related state in an interpreter.

X *
X * Results:
X * None.
X *
X * Side effects:

X * History info is initialized in iPtr.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_InitHistory(interp)
X Tcl_Interp *interp; /* Interpreter to initialize. */

X{
X register Interp *iPtr = (Interp *) interp;

X int i;
X
X if (iPtr->numEvents != 0) {
X return;
X }
X iPtr->numEvents = 20;
X iPtr->events = (HistoryEvent *)
X ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent)));
X for (i = 0; i < iPtr->numEvents; i++) {
X iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
X *iPtr->events[i].command = 0;
X iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE;
X }

X iPtr->curEvent = 0;
X iPtr->curEventNum = 0;

X Tcl_CreateCommand((Tcl_Interp *) iPtr, "history", Tcl_HistoryCmd,
X (ClientData) NULL, (void (*)()) NULL);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_RecordAndEval --
X *
X * This procedure adds its command argument to the current list of
X * recorded events and then executes the command by calling Tcl_Eval.

X *
X * Results:

X * The return value is a standard Tcl return value, the result of
X * executing cmd.

X *
X * Side effects:

X * The command is recorded and executed. In addition, pending history
X * revisions are carried out, and information is set up to enable
X * Tcl_Eval to identify history command ranges. This procedure also
X * initializes history information for the interpreter, if it hasn't
X * already been initialized.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_RecordAndEval(interp, cmd, flags)
X Tcl_Interp *interp; /* Token for interpreter in which command
X * will be executed. */
X char *cmd; /* Command to record. */
X int flags; /* Additional flags to pass to Tcl_Eval.
X * TCL_NO_EVAL means only record: don't
X * execute command. */

X{
X register Interp *iPtr = (Interp *) interp;

X register HistoryEvent *eventPtr;
X int length, result;
X
X if (iPtr->numEvents == 0) {
X Tcl_InitHistory(interp);
X }
X DoRevs(iPtr);
X
X /*
X * Don't record empty commands.
X */
X
X while (isspace(*cmd)) {
X cmd++;
X }
X if (*cmd == '\0') {
X Tcl_ResetResult(interp);

X return TCL_OK;
X }
X

X iPtr->curEventNum++;
X iPtr->curEvent++;
X if (iPtr->curEvent >= iPtr->numEvents) {

X iPtr->curEvent = 0;
X }

X eventPtr = &iPtr->events[iPtr->curEvent];
X
X /*
X * Chop off trailing newlines before recording the command.
X */
X
X length = strlen(cmd);
X while (cmd[length-1] == '\n') {
X length--;
X }
X MakeSpace(eventPtr, length + 1);
X strncpy(eventPtr->command, cmd, length);
X eventPtr->command[length] = 0;
X
X /*
X * Execute the command. Note: history revision isn't possible after
X * a nested call to this procedure, because the event at the top of
X * the history list no longer corresponds to what's going on when
X * a nested call here returns. Thus, must leave history revision
X * disabled when we return.
X */
X
X result = TCL_OK;
X if (flags != TCL_NO_EVAL) {
X iPtr->historyFirst = cmd;
X iPtr->revDisables = 0;
X result = Tcl_Eval(interp, cmd, flags | TCL_RECORD_BOUNDS,
X (char **) NULL);
X }

X iPtr->revDisables = 1;

X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_HistoryCmd --
X *
X * This procedure is invoked to process the "history" 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_HistoryCmd(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 HistoryEvent *eventPtr;

X int length;
X char c;
X

X /*
X * If no arguments, treat the same as "history info".
X */
X

X if (argc == 1) {

X goto infoCmd;
X }

X
X c = argv[1][0];
X length = strlen(argv[1]);
X

X if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) {
X if ((argc != 3) && (argc != 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " add event ?exec?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (argc == 4) {
X if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) {
X Tcl_AppendResult(interp, "bad argument \"", argv[3],
X "\": should be \"exec\"", (char *) NULL);
X return TCL_ERROR;
X }
X return Tcl_RecordAndEval(interp, argv[2], 0);
X }
X return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL);
X } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) {
X if ((argc != 3) && (argc != 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " change newValue ?event?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (argc == 3) {
X eventPtr = &iPtr->events[iPtr->curEvent];
X iPtr->revDisables += 1;

X while (iPtr->revPtr != NULL) {

X HistoryRev *nextPtr;
X
X ckfree(iPtr->revPtr->newBytes);
X nextPtr = iPtr->revPtr->nextPtr;

X ckfree((char *) iPtr->revPtr);
X iPtr->revPtr = nextPtr;
X }

X } else {
X eventPtr = GetEvent(iPtr, argv[3]);
X if (eventPtr == NULL) {

X return TCL_ERROR;
X }
X }

X MakeSpace(eventPtr, strlen(argv[2]) + 1);
X strcpy(eventPtr->command, argv[2]);
X return TCL_OK;
X } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) {
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " event ?event?\"", (char *) NULL);
X return TCL_ERROR;
X }
X eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
X if (eventPtr == NULL) {
X return TCL_ERROR;
X }
X RevResult(iPtr, eventPtr->command);
X Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE);
X return TCL_OK;
X } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) {
X int count, indx, i;
X char *newline;

X
X if ((argc != 2) && (argc != 3)) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " info ?count?\"", (char *) NULL);
X return TCL_ERROR;
X }
X infoCmd:
X if (argc == 3) {
X if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
X return TCL_ERROR;
X }
X if (count > iPtr->numEvents) {
X count = iPtr->numEvents;
X }
X } else {
X count = iPtr->numEvents;
X }
X newline = "";
X for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count;
X i < count; i++, indx++) {
X char *cur, *next, savedChar;
X char serial[20];
X
X if (indx >= iPtr->numEvents) {
X indx -= iPtr->numEvents;
X }
X cur = iPtr->events[indx].command;
X if (*cur == '\0') {
X continue; /* No command recorded here. */
X }
X sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i));
X Tcl_AppendResult(interp, newline, serial, (char *) NULL);
X newline = "\n";
X
X /*
X * Tricky formatting here: for multi-line commands, indent
X * the continuation lines.
X */
X
X while (1) {
X next = strchr(cur, '\n');
X if (next == NULL) {
X break;
X }
X next++;
X savedChar = *next;
X *next = 0;
X Tcl_AppendResult(interp, cur, "\t", (char *) NULL);
X *next = savedChar;
X cur = next;
X }
X Tcl_AppendResult(interp, cur, (char *) NULL);
X }
X return TCL_OK;
X } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) {
X int count, i, src;
X HistoryEvent *events;

X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " keep number\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
X return TCL_ERROR;
X }
X if ((count <= 0) || (count > 1000)) {
X Tcl_AppendResult(interp, "illegal keep count \"", argv[2],

X "\"", (char *) NULL);
X return TCL_ERROR;
X }
X

X /*
X * Create a new history array and copy as much existing history
X * as possible from the old array.
X */
X
X events = (HistoryEvent *)
X ckalloc((unsigned) (count * sizeof(HistoryEvent)));
X if (count < iPtr->numEvents) {
X src = iPtr->curEvent + 1 - count;
X if (src < 0) {
X src += iPtr->numEvents;
X }
X } else {
X src = iPtr->curEvent + 1;
X }
X for (i = 0; i < count; i++, src++) {
X if (src >= iPtr->numEvents) {
X src = 0;
X }
X if (i < iPtr->numEvents) {
X events[i] = iPtr->events[src];
X iPtr->events[src].command = NULL;
X } else {
X events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
X events[i].command[0] = 0;
X events[i].bytesAvl = INITIAL_CMD_SIZE;

X }
X }
X
X /*

X * Throw away everything left in the old history array, and
X * substitute the new one for the old one.
X */
X

X for (i = 0; i < iPtr->numEvents; i++) {

X if (iPtr->events[i].command != NULL) {

X ckfree(iPtr->events[i].command);

X }
X }
X ckfree((char *) iPtr->events);
X iPtr->events = events;
X if (count < iPtr->numEvents) {
X iPtr->curEvent = count-1;
X } else {
X iPtr->curEvent = iPtr->numEvents-1;
X }
X iPtr->numEvents = count;
X return TCL_OK;
X } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) {
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " nextid\"", (char *) NULL);
X return TCL_ERROR;
X }
X sprintf(iPtr->result, "%d", iPtr->curEventNum+1);
X return TCL_OK;
X } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) {
X if (argc > 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " redo ?event?\"", (char *) NULL);
X return TCL_ERROR;
X }
X eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
X if (eventPtr == NULL) {
X return TCL_ERROR;
X }
X RevCommand(iPtr, eventPtr->command);
X return Tcl_Eval(interp, eventPtr->command, 0, (char **) NULL);
X } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) {
X if ((argc > 5) || (argc < 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " substitute old new ?event?\"", (char *) NULL);
X return TCL_ERROR;
X }
X eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]);
X if (eventPtr == NULL) {
X return TCL_ERROR;
X }
X return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]);
X } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) {
X char *words;
X
X if ((argc != 3) && (argc != 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " words num-num/pat ?event?\"", (char *) NULL);
X return TCL_ERROR;
X }
X eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]);
X if (eventPtr == NULL) {
X return TCL_ERROR;
X }
X words = GetWords(iPtr, eventPtr->command, argv[2]);
X if (words == NULL) {
X return TCL_ERROR;
X }
X RevResult(iPtr, words);
X iPtr->result = words;

X iPtr->freeProc = (Tcl_FreeProc *) free;
X return TCL_OK;
X }
X

X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": must be add, change, event, info, keep, nextid, ",
X "redo, substitute, or words", (char *) NULL);
X return TCL_ERROR;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * MakeSpace --
X *
X * Given a history event, make sure it has enough space for
X * a string of a given length (enlarge the string area if
X * necessary).

X *
X * Results:
X * None.
X *
X * Side effects:

X * More memory may get allocated.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XMakeSpace(hPtr, size)
X HistoryEvent *hPtr;
X int size; /* # of bytes needed in hPtr. */
X{
X if (hPtr->bytesAvl < size) {
X ckfree(hPtr->command);
X hPtr->command = (char *) ckalloc((unsigned) size);
X hPtr->bytesAvl = size;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * InsertRev --
X *
X * Add a new revision to the list of those pending for iPtr.
X * Do it in a way that keeps the revision list sorted in
X * increasing order of firstIndex. Also, eliminate revisions
X * that are subsets of other revisions.

X *
X * Results:
X * None.
X *
X * Side effects:

X * RevPtr is added to iPtr's revision list.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XInsertRev(iPtr, revPtr)
X Interp *iPtr; /* Interpreter to use. */
X register HistoryRev *revPtr; /* Revision to add to iPtr's list. */
X{
X register HistoryRev *curPtr;
X register HistoryRev *prevPtr;
X
X for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL;
X prevPtr = curPtr, curPtr = curPtr->nextPtr) {
X /*
X * If this revision includes the new one (or vice versa) then
X * just eliminate the one that is a subset of the other.
X */
X
X if ((revPtr->firstIndex <= curPtr->firstIndex)
X && (revPtr->lastIndex >= curPtr->firstIndex)) {
X curPtr->firstIndex = revPtr->firstIndex;
X curPtr->lastIndex = revPtr->lastIndex;
X curPtr->newSize = revPtr->newSize;
X ckfree(curPtr->newBytes);
X curPtr->newBytes = revPtr->newBytes;
X ckfree((char *) revPtr);
X return;
X }
X if ((revPtr->firstIndex >= curPtr->firstIndex)
X && (revPtr->lastIndex <= curPtr->lastIndex)) {
X ckfree(revPtr->newBytes);
X ckfree((char *) revPtr);
X return;
X }
X
X if (revPtr->firstIndex < curPtr->firstIndex) {

X break;
X }
X }
X

X /*
X * Insert revPtr just after prevPtr.
X */
X
X if (prevPtr == NULL) {
X revPtr->nextPtr = iPtr->revPtr;
X iPtr->revPtr = revPtr;
X } else {
X revPtr->nextPtr = prevPtr->nextPtr;
X prevPtr->nextPtr = revPtr;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * RevCommand --
X *
X * This procedure is invoked by the "history" command to record
X * a command revision. See the comments at the beginning of the
X * file for more information about revisions.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Revision information is recorded.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XRevCommand(iPtr, string)
X register Interp *iPtr; /* Interpreter in which to perform the
X * substitution. */
X char *string; /* String to substitute. */
X{
X register HistoryRev *revPtr;
X
X if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
X return;
X }
X revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
X revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst;
X revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst;
X revPtr->newSize = strlen(string);
X revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1));
X strcpy(revPtr->newBytes, string);
X InsertRev(iPtr, revPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * RevResult --
X *
X * This procedure is invoked by the "history" command to record
X * a result revision. See the comments at the beginning of the
X * file for more information about revisions.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Revision information is recorded.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XRevResult(iPtr, string)
X register Interp *iPtr; /* Interpreter in which to perform the
X * substitution. */
X char *string; /* String to substitute. */
X{
X register HistoryRev *revPtr;
X char *evalFirst, *evalLast;
X char *argv[2];
X
X if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
X return;
X }
X
X /*
X * Expand the replacement range to include the brackets that surround
X * the command. If there aren't any brackets (i.e. this command was
X * invoked at top-level) then don't do any revision. Also, if there
X * are several commands in brackets, of which this is just one,
X * then don't do any revision.
X */
X
X evalFirst = iPtr->evalFirst;
X evalLast = iPtr->evalLast + 1;
X while (1) {
X if (evalFirst == iPtr->historyFirst) {
X return;
X }
X evalFirst--;
X if (*evalFirst == '[') {
X break;
X }
X if (!isspace(*evalFirst)) {
X return;
X }
X }
X if (*evalLast != ']') {
X return;
X }
X
X revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
X revPtr->firstIndex = evalFirst - iPtr->historyFirst;
X revPtr->lastIndex = evalLast - iPtr->historyFirst;
X argv[0] = string;
X revPtr->newBytes = Tcl_Merge(1, argv);
X revPtr->newSize = strlen(revPtr->newBytes);
X InsertRev(iPtr, revPtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * DoRevs --
X *
X * This procedure is called to apply the history revisions that
X * have been recorded in iPtr.

X *
X * Results:
X * None.
X *
X * Side effects:

X * The most recent entry in the history for iPtr may be modified.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XDoRevs(iPtr)
X register Interp *iPtr; /* Interpreter whose history is to
X * be modified. */
X{
X register HistoryRev *revPtr;
X register HistoryEvent *eventPtr;
X char *newCommand, *p;
X unsigned int size;
X int bytesSeen, count;
X
X if (iPtr->revPtr == NULL) {
X return;
X }
X
X /*
X * The revision is done in two passes. The first pass computes the
X * amount of space needed for the revised event, and the second pass
X * pieces together the new event and frees up the revisions.
X */
X
X eventPtr = &iPtr->events[iPtr->curEvent];
X size = strlen(eventPtr->command) + 1;
X for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) {
X size -= revPtr->lastIndex + 1 - revPtr->firstIndex;
X size += revPtr->newSize;
X }
X
X newCommand = (char *) ckalloc(size);
X p = newCommand;
X bytesSeen = 0;
X for (revPtr = iPtr->revPtr; revPtr != NULL; ) {
X HistoryRev *nextPtr = revPtr->nextPtr;
X
X count = revPtr->firstIndex - bytesSeen;
X if (count > 0) {
X strncpy(p, eventPtr->command + bytesSeen, count);
X p += count;
X }
X strncpy(p, revPtr->newBytes, revPtr->newSize);
X p += revPtr->newSize;
X bytesSeen = revPtr->lastIndex+1;
X ckfree(revPtr->newBytes);
X ckfree((char *) revPtr);
X revPtr = nextPtr;
X }
X if (&p[strlen(&eventPtr->command[bytesSeen]) + 1] >
X &newCommand[size]) {
X printf("Assertion failed!\n");
X }
X strcpy(p, eventPtr->command + bytesSeen);
X
X /*
X * Replace the command in the event.
X */
X
X ckfree(eventPtr->command);
X eventPtr->command = newCommand;
X eventPtr->bytesAvl = size;

X iPtr->revPtr = NULL;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * GetEvent --
X *
X * Given a textual description of an event (see the manual page
X * for legal values) find the corresponding event and return its
X * command string.

X *
X * Results:

X * The return value is a pointer to the event named by "string".
X * If no such event exists, then NULL is returned and an error
X * message is left in iPtr.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic HistoryEvent *
XGetEvent(iPtr, string)
X register Interp *iPtr; /* Interpreter in which to look. */
X char *string; /* Description of event. */
X{
X int eventNum, index;
X register HistoryEvent *eventPtr;
X int length;
X
X /*
X * First check for a numeric specification of an event.
X */
X
X if (isdigit(*string) || (*string == '-')) {
X if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) {
X return NULL;
X }
X if (eventNum < 0) {
X eventNum += iPtr->curEventNum;
X }
X if (eventNum > iPtr->curEventNum) {
X Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
X "\" hasn't occurred yet", (char *) NULL);
X return NULL;
X }
X if ((eventNum <= iPtr->curEventNum-iPtr->numEvents)
X || (eventNum <= 0)) {
X Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
X "\" is too far in the past", (char *) NULL);
X return NULL;
X }
X index = iPtr->curEvent + (eventNum - iPtr->curEventNum);
X if (index < 0) {
X index += iPtr->numEvents;
X }
X return &iPtr->events[index];
X }
X
X /*
X * Next, check for an event that contains the string as a prefix or
X * that matches the string in the sense of Tcl_StringMatch.
X */

X
X length = strlen(string);

X for (index = iPtr->curEvent - 1; ; index--) {
X if (index < 0) {
X index += iPtr->numEvents;
X }
X if (index == iPtr->curEvent) {
X break;
X }
X eventPtr = &iPtr->events[index];
X if ((strncmp(eventPtr->command, string, length) == 0)
X || Tcl_StringMatch(eventPtr->command, string)) {
X return eventPtr;
X }
X }
X
X Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string,

X "\"", (char *) NULL);

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * SubsAndEval --
X *
X * Generate a new command by making a textual substitution in
X * the "cmd" argument. Then execute the new command.

X *
X * Results:

X * The return value is a standard Tcl error.

X *
X * Side effects:

X * History gets revised if the substitution is occurring on
X * a recorded command line. Also, the re-executed command
X * may produce side-effects.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XSubsAndEval(iPtr, cmd, old, new)
X register Interp *iPtr; /* Interpreter in which to execute
X * new command. */
X char *cmd; /* Command in which to substitute. */
X char *old; /* String to search for in command. */
X char *new; /* Replacement string for "old". */
X{
X char *src, *dst, *newCmd;
X int count, oldLength, newLength, length, result;
X
X /*
X * Figure out how much space it will take to hold the
X * substituted command (and complain if the old string
X * doesn't appear in the original command).
X */
X
X oldLength = strlen(old);
X newLength = strlen(new);
X src = cmd;
X count = 0;
X while (1) {
X src = strstr(src, old);
X if (src == NULL) {
X break;
X }
X src += oldLength;
X count++;
X }

X if (count == 0) {

X Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old,
X "\" doesn't appear in event", (char *) NULL);
X return TCL_ERROR;
X }
X length = strlen(cmd) + count*(newLength - oldLength);
X
X /*
X * Generate a substituted command.
X */
X
X newCmd = (char *) ckalloc((unsigned) (length + 1));
X dst = newCmd;
X while (1) {
X src = strstr(cmd, old);
X if (src == NULL) {
X strcpy(dst, cmd);
X break;
X }
X strncpy(dst, cmd, src-cmd);
X dst += src-cmd;
X strcpy(dst, new);
X dst += newLength;
X cmd = src + oldLength;
X }
X
X RevCommand(iPtr, newCmd);
X result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd, 0, (char **) NULL);
X ckfree(newCmd);
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * GetWords --
X *
X * Given a command string, return one or more words from the
X * command string.

X *
X * Results:

X * The return value is a pointer to a dynamically-allocated
X * string containing the words of command specified by "words".
X * If the word specifier has improper syntax then an error
X * message is placed in iPtr->result and NULL is returned.

X *
X * Side effects:

X * Memory is allocated. It is the caller's responsibilty to
X * free the returned string..

X *
X *----------------------------------------------------------------------
X */
X

Xstatic char *
XGetWords(iPtr, command, words)
X register Interp *iPtr; /* Tcl interpreter in which to place
X * an error message if needed. */
X char *command; /* Command string. */
X char *words; /* Description of which words to extract
X * from the command. Either num[-num] or
X * a pattern. */
X{
X char *result;
X char *start, *end, *dst;
X register char *next;
X int first; /* First word desired. -1 means last word
X * only. */
X int last; /* Last word desired. -1 means use everything
X * up to the end. */
X int index; /* Index of current word. */
X char *pattern;
X
X /*
X * Figure out whether we're looking for a numerical range or for
X * a pattern.
X */
X
X pattern = NULL;
X first = 0;
X last = -1;
X if (*words == '$') {
X if (words[1] != '\0') {
X goto error;
X }
X first = -1;
X } else if (isdigit(*words)) {
X first = strtoul(words, &start, 0);
X if (*start == 0) {
X last = first;
X } else if (*start == '-') {
X start++;
X if (*start == '$') {
X start++;
X } else if (isdigit(*start)) {
X last = strtoul(start, &start, 0);
X } else {
X goto error;
X }
X if (*start != 0) {

X goto error;
X }
X }

X if ((first > last) && (last != -1)) {

X goto error;
X }
X } else {

X pattern = words;
X }
X
X /*
X * Scan through the words one at a time, copying those that are
X * relevant into the result string. Allocate a result area large
X * enough to hold all the words if necessary.
X */
X
X result = (char *) ckalloc((unsigned) (strlen(command) + 1));
X dst = result;
X for (next = command; isspace(*next); next++) {
X /* Empty loop body: just find start of first word. */
X }
X for (index = 0; *next != 0; index++) {
X start = next;
X end = TclWordEnd(next, 0);
X for (next = end; isspace(*next); next++) {
X /* Empty loop body: just find start of next word. */
X }
X if ((first > index) || ((first == -1) && (*next != 0))) {
X continue;
X }
X if ((last != -1) && (last < index)) {
X continue;
X }
X if (pattern != NULL) {
X int match;
X char savedChar = *end;
X
X *end = 0;
X match = Tcl_StringMatch(start, pattern);
X *end = savedChar;
X if (!match) {
X continue;
X }
X }
X if (dst != result) {
X *dst = ' ';
X dst++;
X }
X strncpy(dst, start, (end-start));
X dst += end-start;
X }
X *dst = 0;
X
X /*
X * Check for an out-of-range argument index.
X */
X
X if ((last >= index) || (first >= index)) {
X ckfree(result);
X Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words,
X "\" specified non-existent words", (char *) NULL);
X return NULL;
X }

X return result;
X
X error:

X Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words,
X "\": should be num-num or pattern", (char *) NULL);
X return NULL;
X}
END_OF_FILE
if test 30514 -ne `wc -c <'tcl6.1/tclHistory.c'`; then
echo shar: \"'tcl6.1/tclHistory.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclHistory.c'
fi
echo shar: End of archive 21 $of 33$.
cp /dev/null ark21isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:52:00 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 90
Archive-name: tcl/part22
Environment: UNIX

# "End of archive 22 (of 33)."
# Contents: tcl6.1/tclVar.c.2
# Wrapped by karl@one on Tue Nov 12 19:44:28 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclVar.c.2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclVar.c.2'\"
else
echo shar: Extracting \"'tcl6.1/tclVar.c.2'\" $30825 characters$
sed "s/^X//" >'tcl6.1/tclVar.c.2' <<'END_OF_FILE'

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_VarTraceInfo2 --
X *
X * Same as Tcl_VarTraceInfo, except takes name in two pieces
X * instead of one.

X *
X * Results:

X * Same as Tcl_VarTraceInfo.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

XClientData
XTcl_VarTraceInfo2(interp, name1, name2, flags, proc, prevClientData)
X Tcl_Interp *interp; /* Interpreter containing variable. */
X char *name1; /* Name of variable or array. */
X char *name2; /* Name of element within array; NULL means
X * trace applies to scalar variable or array
X * as-a-whole. */
X int flags; /* 0 or TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
X ClientData prevClientData; /* If non-NULL, gives last value returned
X * by this procedure, so this call will
X * return the next trace after that one.
X * If NULL, this call will return the
X * first trace. */
X{
X register VarTrace *tracePtr;
X Var *varPtr;
X Interp *iPtr = (Interp *) interp;
X Tcl_HashEntry *hPtr;
X
X /*
X * First, lookup the variable.
X */
X
X if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X } else {
X hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);

X }
X if (hPtr == NULL) {

X return NULL;
X }

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {

X hPtr = varPtr->value.upvarPtr;

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X }

X if (name2 != NULL) {

X if (!(varPtr->flags & VAR_ARRAY)) {

X return NULL;
X }
X hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);

X if (hPtr == NULL) {

X return NULL;
X }

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * Find the relevant trace, if any, and return its clientData.
X */
X
X tracePtr = varPtr->tracePtr;
X if (prevClientData != NULL) {
X for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
X if ((tracePtr->clientData == prevClientData)
X && (tracePtr->traceProc == proc)) {
X tracePtr = tracePtr->nextPtr;

X break;
X }
X }
X }

X for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
X if (tracePtr->traceProc == proc) {
X return tracePtr->clientData;
X }
X }

X return NULL;
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], TCL_LEAVE_ERR_MSG);
X if (value == NULL) {
X return TCL_ERROR;
X }
X interp->result = value;
X return TCL_OK;
X } else if (argc == 3) {
X char *result;
X
X result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
X if (result == NULL) {
X return TCL_ERROR;
X }
X interp->result = result;
X return TCL_OK;
X } else {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " varName ?newValue?\"", (char *) NULL);
X return TCL_ERROR;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UnsetCmd --
X *
X * This procedure is invoked to process the "unset" 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_UnsetCmd(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 int i;
X
X if (argc < 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " varName ?varName ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X for (i = 1; i < argc; i++) {
X if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {

X return TCL_ERROR;
X }
X }

X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_AppendCmd --
X *
X * This procedure is invoked to process the "append" 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_AppendCmd(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 int i;
X char *result = NULL; /* (Initialization only needed to keep
X * the compiler from complaining) */
X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " varName value ?value ...?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X for (i = 2; i < argc; i++) {
X result = Tcl_SetVar(interp, argv[1], argv[i],
X TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
X if (result == NULL) {

X return TCL_ERROR;
X }
X }

X interp->result = result;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_LappendCmd --
X *
X * This procedure is invoked to process the "lappend" 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_LappendCmd(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 int i;
X char *result = NULL; /* (Initialization only needed to keep
X * the compiler from complaining) */
X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " varName value ?value ...?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X for (i = 2; i < argc; i++) {
X result = Tcl_SetVar(interp, argv[1], argv[i],
X TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
X if (result == NULL) {

X return TCL_ERROR;
X }
X }

X interp->result = result;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ArrayCmd --
X *
X * This procedure is invoked to process the "array" 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_ArrayCmd(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 int length;
X char c;

X Var *varPtr;
X Tcl_HashEntry *hPtr;
X Interp *iPtr = (Interp *) interp;
X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " option arrayName ?arg ...?\"", (char *) NULL);

X return TCL_ERROR;
X }
X
X /*

X * Locate the array variable (and it better be an array).
X */
X

X if (iPtr->varFramePtr == NULL) {
X hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
X } else {
X hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
X }
X if (hPtr == NULL) {

X notArray:
X Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
X (char *) NULL);
X return TCL_ERROR;
X }

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
X }
X if (!(varPtr->flags & VAR_ARRAY)) {

X goto notArray;
X }
X
X /*
X * Dispatch based on the option.
X */

X
X c = argv[1][0];
X length = strlen(argv[1]);

X if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
X ArraySearch *searchPtr;
X
X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " anymore arrayName searchId\"", (char *) NULL);
X return TCL_ERROR;
X }
X searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X if (searchPtr == NULL) {
X return TCL_ERROR;
X }
X while (1) {
X Var *varPtr2;
X
X if (searchPtr->nextEntry != NULL) {
X varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
X if (!(varPtr2->flags & VAR_UNDEFINED)) {
X break;
X }
X }
X searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
X if (searchPtr->nextEntry == NULL) {
X interp->result = "0";

X return TCL_OK;
X }
X }

X interp->result = "1";
X return TCL_OK;
X } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
X ArraySearch *searchPtr, *prevPtr;
X
X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " donesearch arrayName searchId\"", (char *) NULL);
X return TCL_ERROR;
X }
X searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X if (searchPtr == NULL) {
X return TCL_ERROR;
X }
X if (varPtr->searchPtr == searchPtr) {
X varPtr->searchPtr = searchPtr->nextPtr;
X } else {
X for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
X if (prevPtr->nextPtr == searchPtr) {
X prevPtr->nextPtr = searchPtr->nextPtr;

X break;
X }
X }
X }

X ckfree((char *) searchPtr);
X } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)

X && (length >= 2)) {

X Tcl_HashSearch search;
X Var *varPtr2;

X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " names arrayName\"", (char *) NULL);
X return TCL_ERROR;
X }
X for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr2->flags & VAR_UNDEFINED) {
X continue;
X }
X Tcl_AppendElement(interp,
X Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
X }
X } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)

X && (length >= 2)) {

X ArraySearch *searchPtr;
X Tcl_HashEntry *hPtr;
X
X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " nextelement arrayName searchId\"",
X (char *) NULL);
X return TCL_ERROR;
X }
X searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X if (searchPtr == NULL) {
X return TCL_ERROR;
X }
X while (1) {
X Var *varPtr2;
X
X hPtr = searchPtr->nextEntry;

X if (hPtr == NULL) {

X hPtr = Tcl_NextHashEntry(&searchPtr->search);

X if (hPtr == NULL) {

X return TCL_OK;
X }
X } else {
X searchPtr->nextEntry = NULL;
X }
X varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X if (!(varPtr2->flags & VAR_UNDEFINED)) {
X break;
X }
X }
X interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
X } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)

X && (length >= 2)) {

X Tcl_HashSearch search;
X Var *varPtr2;
X int size;

X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " size arrayName\"", (char *) NULL);
X return TCL_ERROR;
X }
X size = 0;
X for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr2->flags & VAR_UNDEFINED) {
X continue;
X }
X size++;
X }
X sprintf(interp->result, "%d", size);
X } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)

X && (length >= 2)) {

X ArraySearch *searchPtr;

X
X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " startsearch arrayName\"", (char *) NULL);
X return TCL_ERROR;
X }
X searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
X if (varPtr->searchPtr == NULL) {
X searchPtr->id = 1;
X Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
X } else {
X char string[20];
X
X searchPtr->id = varPtr->searchPtr->id + 1;
X sprintf(string, "%d", searchPtr->id);
X Tcl_AppendResult(interp, "s-", string, "-", argv[2],
X (char *) NULL);
X }
X searchPtr->varPtr = varPtr;
X searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
X &searchPtr->search);
X searchPtr->nextPtr = varPtr->searchPtr;
X varPtr->searchPtr = searchPtr;
X } else {

X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": should be anymore, donesearch, names, nextelement, ",
X "size, or startsearch", (char *) NULL);
X return TCL_ERROR;
X }
X return TCL_OK;
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 Var *varPtr, *gVarPtr;

X register Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr, *hPtr2;
X int new;

X
X if (argc < 2) {

X Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
X argv[0], " varName ?varName ...?\"", (char *) NULL);
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 hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
X if (new) {
X gVarPtr = NewVar(0);
X gVarPtr->flags |= VAR_UNDEFINED;
X Tcl_SetHashValue(hPtr, gVarPtr);
X } else {
X gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X }
X hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
X if (!new) {
X Var *varPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr2);

X if (varPtr->flags & VAR_UPVAR) {

X continue;
X } else {
X Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
X "\" already exists", (char *) NULL);

X return TCL_ERROR;
X }
X }

X varPtr = NewVar(0);
X varPtr->flags |= VAR_UPVAR;
X varPtr->value.upvarPtr = hPtr;
X gVarPtr->upvarUses++;
X Tcl_SetHashValue(hPtr2, varPtr);

X }
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UpvarCmd --
X *
X * This procedure is invoked to process the "upvar" 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_UpvarCmd(dummy, interp, argc, argv)

X int result;
X CallFrame *framePtr;
X Var *varPtr = NULL;
X Tcl_HashTable *upVarTablePtr;
X Tcl_HashEntry *hPtr, *hPtr2;
X int new;
X Var *upVarPtr;
X
X if (argc < 3) {
X upvarSyntax:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?level? otherVar localVar ?otherVar localVar ...?\"",
X (char *) NULL);

X return TCL_ERROR;
X }
X
X /*

X * Find the hash table containing the variable being referenced.
X */
X

X result = TclGetFrame(interp, argv[1], &framePtr);
X if (result == -1) {

X return TCL_ERROR;
X }
X argc -= result+1;
X argv += result+1;

X if (framePtr == NULL) {

X upVarTablePtr = &iPtr->globalTable;
X } else {
X upVarTablePtr = &framePtr->varTable;
X }
X
X if ((argc & 1) != 0) {
X goto upvarSyntax;
X }
X
X /*
X * Iterate over all the pairs of (local variable, other variable)
X * names. For each pair, create a hash table entry in the upper
X * context (if the name wasn't there already), then associate it
X * with a new local variable.
X */
X
X while (argc > 0) {
X hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
X if (new) {
X upVarPtr = NewVar(0);
X upVarPtr->flags |= VAR_UNDEFINED;
X Tcl_SetHashValue(hPtr, upVarPtr);
X } else {
X upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (upVarPtr->flags & VAR_UPVAR) {
X hPtr = upVarPtr->value.upvarPtr;
X upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X }
X }
X
X hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
X argv[1], &new);
X if (!new) {
X Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
X "\" already exists", (char *) NULL);
X return TCL_ERROR;
X }
X varPtr = NewVar(0);
X varPtr->flags |= VAR_UPVAR;
X varPtr->value.upvarPtr = hPtr;
X upVarPtr->upvarUses++;
X Tcl_SetHashValue(hPtr2, varPtr);
X

X argc -= 2;
X argv += 2;

X }
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * TclDeleteVars --
X *
X * This procedure is called to recycle all the storage space
X * associated with a table of variables. For this procedure
X * to work correctly, it must not be possible for any of the
X * variable in the table to be accessed from Tcl commands
X * (e.g. from trace procedures).

X *
X * Results:
X * None.
X *
X * Side effects:

X * Variables are deleted and trace procedures are invoked, if
X * any are declared.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTclDeleteVars(iPtr, tablePtr)
X Interp *iPtr; /* Interpreter to which variables belong. */
X Tcl_HashTable *tablePtr; /* Hash table containing variables to
X * delete. */
X{
X Tcl_HashSearch search;
X Tcl_HashEntry *hPtr;
X register Var *varPtr;
X int flags, globalFlag;
X
X flags = TCL_TRACE_UNSETS;
X if (tablePtr == &iPtr->globalTable) {
X flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
X }
X for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
X hPtr = Tcl_NextHashEntry(&search)) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X
X /*
X * For global/upvar variables referenced in procedures, free up the
X * local space and then decrement the reference count on the
X * variable referred to. If there are no more references to the
X * global/upvar and it is undefined and has no traces set, then
X * follow on and delete the referenced variable too.
X */
X
X globalFlag = 0;

X if (varPtr->flags & VAR_UPVAR) {

X hPtr = varPtr->value.upvarPtr;
X ckfree((char *) varPtr);

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X varPtr->upvarUses--;
X if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
X || (varPtr->tracePtr != NULL)) {
X continue;
X }
X globalFlag = TCL_GLOBAL_ONLY;
X }
X
X /*
X * Invoke traces on the variable that is being deleted, then
X * free up the variable's space (no need to free the hash entry
X * here, unless we're dealing with a global variable: the
X * hash entries will be deleted automatically when the whole
X * table is deleted).
X */
X
X if (varPtr->tracePtr != NULL) {
X (void) CallTraces(iPtr, (Var *) NULL, hPtr,
X Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
X flags | globalFlag);
X while (varPtr->tracePtr != NULL) {
X VarTrace *tracePtr = varPtr->tracePtr;
X varPtr->tracePtr = tracePtr->nextPtr;

X ckfree((char *) tracePtr);
X }

X }
X if (varPtr->flags & VAR_ARRAY) {
X DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
X flags | globalFlag);
X }
X if (globalFlag) {
X Tcl_DeleteHashEntry(hPtr);
X }
X ckfree((char *) varPtr);
X }
X Tcl_DeleteHashTable(tablePtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * CallTraces --
X *
X * This procedure is invoked to find and invoke relevant
X * trace procedures associated with a particular operation on
X * a variable. This procedure invokes traces both on the
X * variable and on its containing array (where relevant).

X *
X * Results:

X * The return value is NULL if no trace procedures were invoked, or
X * if all the invoked trace procedures returned successfully.
X * The return value is non-zero if a trace procedure returned an
X * error (in this case no more trace procedures were invoked after
X * the error was returned). In this case the return value is a
X * pointer to a static string describing the error.

X *
X * Side effects:

X * Almost anything can happen, depending on trace; this procedure
X * itself doesn't have any side effects.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic char *
XCallTraces(iPtr, arrayPtr, hPtr, name1, name2, flags)
X Interp *iPtr; /* Interpreter containing variable. */
X register Var *arrayPtr; /* Pointer to array variable that
X * contains the variable, or NULL if
X * the variable isn't an element of an
X * array. */
X Tcl_HashEntry *hPtr; /* Hash table entry corresponding to
X * variable whose traces are to be
X * invoked. */
X char *name1, *name2; /* Variable's two-part name. */
X int flags; /* Flags to pass to trace procedures:
X * indicates what's happening to
X * variable, plus other stuff like
X * TCL_GLOBAL_ONLY and
X * TCL_INTERP_DESTROYED. */
X{
X Var *varPtr;
X register VarTrace *tracePtr;
X ActiveVarTrace active;
X char *result;
X int savedArrayFlags = 0; /* (Initialization not needed except
X * to prevent compiler warning) */
X
X /*
X * If there are already similar trace procedures active for the
X * variable, don't call them again.
X */

X
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X if (varPtr->flags & VAR_TRACE_ACTIVE) {
X return NULL;
X }
X varPtr->flags |= VAR_TRACE_ACTIVE;
X
X /*
X * Invoke traces on the array containing the variable, if relevant.
X */
X
X result = NULL;
X active.nextPtr = iPtr->activeTracePtr;
X iPtr->activeTracePtr = &active;
X if (arrayPtr != NULL) {
X savedArrayFlags = arrayPtr->flags;
X arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
X for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
X tracePtr = active.nextTracePtr) {
X active.nextTracePtr = tracePtr->nextPtr;
X if (!(tracePtr->flags & flags)) {
X continue;
X }
X result = (*tracePtr->traceProc)(tracePtr->clientData,
X (Tcl_Interp *) iPtr, name1, name2, flags);
X if (result != NULL) {

X if (flags & TCL_TRACE_UNSETS) {

X result = NULL;
X } else {
X goto done;
X }
X }

X }
X }
X
X /*

X * Invoke traces on the variable itself.
X */
X
X if (flags & TCL_TRACE_UNSETS) {
X flags |= TCL_TRACE_DESTROYED;
X }
X for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
X tracePtr = active.nextTracePtr) {
X active.nextTracePtr = tracePtr->nextPtr;
X if (!(tracePtr->flags & flags)) {
X continue;
X }
X result = (*tracePtr->traceProc)(tracePtr->clientData,
X (Tcl_Interp *) iPtr, name1, name2, flags);
X if (result != NULL) {

X if (flags & TCL_TRACE_UNSETS) {

X result = NULL;
X } else {
X goto done;
X }

X }
X }
X
X /*

X * Restore the variable's flags, remove the record of our active
X * traces, and then return. Remember that the variable could have
X * been re-allocated during the traces, but its hash entry won't
X * change.

X */
X
X done:

X if (arrayPtr != NULL) {
X arrayPtr->flags = savedArrayFlags;

X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X varPtr->flags &= ~VAR_TRACE_ACTIVE;
X iPtr->activeTracePtr = active.nextPtr;
X return result;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * NewVar --
X *
X * Create a new variable with a given initial value.

X *
X * Results:

X * The return value is a pointer to the new variable structure.
X * The variable will not be part of any hash table yet, and its
X * upvarUses count is initialized to 0. Its initial value will
X * be empty, but "space" bytes will be available in the value
X * area.

X *
X * Side effects:

X * Storage gets allocated.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic Var *
XNewVar(space)
X int space; /* Minimum amount of space to allocate
X * for variable's value. */
X{
X int extra;
X register Var *varPtr;
X
X extra = space - sizeof(varPtr->value);
X if (extra < 0) {
X extra = 0;
X space = sizeof(varPtr->value);
X }
X varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
X varPtr->valueLength = 0;
X varPtr->valueSpace = space;
X varPtr->upvarUses = 0;
X varPtr->tracePtr = NULL;
X varPtr->searchPtr = NULL;
X varPtr->flags = 0;
X varPtr->value.string[0] = 0;
X return varPtr;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * ParseSearchId --
X *
X * This procedure translates from a string to a pointer to an
X * active array search (if there is one that matches the string).

X *
X * Results:

X * The return value is a pointer to the array search indicated
X * by string, or NULL if there isn't one. If NULL is returned,
X * interp->result contains an error message.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic ArraySearch *
XParseSearchId(interp, varPtr, varName, string)
X Tcl_Interp *interp; /* Interpreter containing variable. */
X Var *varPtr; /* Array variable search is for. */
X char *varName; /* Name of array variable that search is
X * supposed to be for. */
X char *string; /* String containing id of search. Must have
X * form "search-num-var" where "num" is a
X * decimal number and "var" is a variable
X * name. */
X{
X char *end;
X int id;
X ArraySearch *searchPtr;
X
X /*
X * Parse the id into the three parts separated by dashes.
X */
X
X if ((string[0] != 's') || (string[1] != '-')) {
X syntax:
X Tcl_AppendResult(interp, "illegal search identifier \"", string,

X "\"", (char *) NULL);

X return NULL;
X }
X id = strtoul(string+2, &end, 10);
X if ((end == (string+2)) || (*end != '-')) {
X goto syntax;
X }
X if (strcmp(end+1, varName) != 0) {
X Tcl_AppendResult(interp, "search identifier \"", string,
X "\" isn't for variable \"", varName, "\"", (char *) NULL);

X return NULL;
X }
X

X /*
X * Search through the list of active searches on the interpreter
X * to see if the desired one exists.
X */
X
X for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
X searchPtr = searchPtr->nextPtr) {
X if (searchPtr->id == id) {
X return searchPtr;
X }
X }
X Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
X (char *) NULL);

X return NULL;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * DeleteSearches --
X *
X * This procedure is called to free up all of the searches
X * associated with an array variable.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Memory is released to the storage allocator.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XDeleteSearches(arrayVarPtr)
X register Var *arrayVarPtr; /* Variable whose searches are
X * to be deleted. */
X{
X ArraySearch *searchPtr;
X
X while (arrayVarPtr->searchPtr != NULL) {
X searchPtr = arrayVarPtr->searchPtr;
X arrayVarPtr->searchPtr = searchPtr->nextPtr;
X ckfree((char *) searchPtr);
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * DeleteArray --
X *
X * This procedure is called to free up everything in an array
X * variable. It's the caller's responsibility to make sure
X * that the array is no longer accessible before this procedure
X * is called.

X *
X * Results:
X * None.
X *
X * Side effects:

X * All storage associated with varPtr's array elements is deleted
X * (including the hash table). Any delete trace procedures for
X * array elements are invoked.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XDeleteArray(iPtr, arrayName, varPtr, flags)
X Interp *iPtr; /* Interpreter containing array. */
X char *arrayName; /* Name of array (used for trace
X * callbacks). */
X Var *varPtr; /* Pointer to variable structure. */
X int flags; /* Flags to pass to CallTraces:
X * TCL_TRACE_UNSETS and sometimes
X * TCL_INTERP_DESTROYED and/or
X * TCL_GLOBAL_ONLY. */
X{
X Tcl_HashSearch search;
X register Tcl_HashEntry *hPtr;
X register Var *elPtr;
X
X DeleteSearches(varPtr);
X for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);

X hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {

X elPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (elPtr->tracePtr != NULL) {
X (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
X Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
X while (elPtr->tracePtr != NULL) {
X VarTrace *tracePtr = elPtr->tracePtr;
X elPtr->tracePtr = tracePtr->nextPtr;

X ckfree((char *) tracePtr);
X }

X }
X if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
X panic("DeleteArray found searches on array alement!");
X }
X ckfree((char *) elPtr);
X }
X Tcl_DeleteHashTable(varPtr->value.tablePtr);
X ckfree((char *) varPtr->value.tablePtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * VarErrMsg --
X *
X * Generate a reasonable error message describing why a variable
X * operation failed.

X *
X * Results:
X * None.
X *
X * Side effects:

X * Interp->result is reset to hold a message identifying the
X * variable given by name1 and name2 and describing why the
X * variable operation failed.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XVarErrMsg(interp, name1, name2, operation, reason)
X Tcl_Interp *interp; /* Interpreter in which to record message. */
X char *name1, *name2; /* Variable's two-part name. */
X char *operation; /* String describing operation that failed,
X * e.g. "read", "set", or "unset". */
X char *reason; /* String describing why operation failed. */
X{
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "can't ", operation, " \"", name1, (char *) NULL);
X if (name2 != NULL) {
X Tcl_AppendResult(interp, "(", name2, ")", (char *) NULL);
X }
X Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
X}
END_OF_FILE
if test 30825 -ne `wc -c <'tcl6.1/tclVar.c.2'`; then
echo shar: \"'tcl6.1/tclVar.c.2'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclVar.c.2'
fi
echo shar: End of archive 22 $of 33$.
cp /dev/null ark22isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:53:57 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 91
Archive-name: tcl/part23
Environment: UNIX

# "End of archive 23 (of 33)."
# Contents: tcl6.1/tclInt.h
# Wrapped by karl@one on Tue Nov 12 19:44:28 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclInt.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclInt.h'\"
else
echo shar: Extracting \"'tcl6.1/tclInt.h'\" $31734 characters$
sed "s/^X//" >'tcl6.1/tclInt.h' <<'END_OF_FILE'
X/*
X * tclInt.h --
X *
X * Declarations of things used internally by the Tcl interpreter.
X *
X * Copyright 1987-1991 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 * $Header: /user6/ouster/tcl/RCS/tclInt.h,v 1.64 91/10/31 16:41:32 ouster Exp $ SPRITE (Berkeley)
X */
X
X#ifndef _TCLINT
X#define _TCLINT
X
X/*
X * Common include files needed by most of the Tcl source files are
X * included here, so that system-dependent personalizations for the
X * include files only have to be made in once place. This results
X * in a few extra includes, but greater modularity. The order of
X * the three groups of #includes is important. For example, stdio.h
X * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is
X * needed by stdlib.h in some configurations.
X */
X
X#include <stdio.h>

X
X#ifndef _TCL
X#include "tcl.h"
X#endif

X#ifndef _TCLHASH
X#include "tclHash.h"
X#endif
X#ifndef _REGEXP
X#include "regexp.h"
X#endif
X
X#include <ctype.h>
X#include <stdlib.h>
X#include <string.h>
X#include <varargs.h>
X
X/*
X *----------------------------------------------------------------
X * Data structures related to variables. These are used primarily
X * in tclVar.c
X *----------------------------------------------------------------
X */
X
X/*
X * The following structure defines a variable trace, which is used to
X * invoke a specific C procedure whenever certain operations are performed
X * on a variable.
X */
X
Xtypedef struct VarTrace {
X Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given
X * by flags are performed on variable. */
X ClientData clientData; /* Argument to pass to proc. */
X int flags; /* What events the trace procedure is
X * interested in: OR-ed combination of
X * TCL_TRACE_READS, TCL_TRACE_WRITES, and
X * TCL_TRACE_UNSETS. */
X struct VarTrace *nextPtr; /* Next in list of traces associated with
X * a particular variable. */
X} VarTrace;
X
X/*
X * When a variable trace is active (i.e. its associated procedure is
X * executing), one of the following structures is linked into a list
X * associated with the variable's interpreter. The information in
X * the structure is needed in order for Tcl to behave reasonably
X * if traces are deleted while traces are active.
X */
X
Xtypedef struct ActiveVarTrace {
X struct ActiveVarTrace *nextPtr;
X /* Next in list of all active variable
X * traces for the interpreter, or NULL
X * if no more. */
X VarTrace *nextTracePtr; /* Next trace to check after current
X * trace procedure returns; if this
X * trace gets deleted, must update pointer
X * to avoid using free'd memory. */
X} ActiveVarTrace;
X
X/*
X * The following structure describes an enumerative search in progress on
X * an array variable; this are invoked with options to the "array"
X * command.
X */
X
Xtypedef struct ArraySearch {
X int id; /* Integer id used to distinguish among
X * multiple concurrent searches for the
X * same array. */
X struct Var *varPtr; /* Pointer to array variable that's being
X * searched. */
X Tcl_HashSearch search; /* Info kept by the hash module about
X * progress through the array. */
X Tcl_HashEntry *nextEntry; /* Non-null means this is the next element
X * to be enumerated (it's leftover from
X * the Tcl_FirstHashEntry call or from
X * an "array anymore" command). NULL
X * means must call Tcl_NextHashEntry
X * to get value to return. */
X struct ArraySearch *nextPtr;/* Next in list of all active searches
X * for this variable, or NULL if this is
X * the last one. */
X} ArraySearch;
X
X/*
X * The structure below defines a variable, which associates a string name
X * with a string value. Pointers to these structures are kept as the
X * values of hash table entries, and the name of each variable is stored
X * in the hash entry.
X */
X
Xtypedef struct Var {
X int valueLength; /* Holds the number of non-null bytes
X * actually occupied by the variable's
X * current value in value.string (extra
X * space is sometimes left for expansion).
X * For array and global variables this is
X * meaningless. */
X int valueSpace; /* Total number of bytes of space allocated
X * at value. */
X int upvarUses; /* Counts number of times variable is
X * is referenced via global or upvar variables
X * (i.e. how many variables have "upvarPtr"
X * pointing to this variable). Variable
X * can't be deleted until this count reaches
X * 0. */
X VarTrace *tracePtr; /* First in list of all traces set for this
X * variable. */
X ArraySearch *searchPtr; /* First in list of all searches active
X * for this variable, or NULL if none. */
X int flags; /* Miscellaneous bits of information about
X * variable. See below for definitions. */
X union {
X char string[4]; /* String value of variable. The actual
X * length of this field is given by the
X * valueSpace field above. */
X Tcl_HashTable *tablePtr;/* For array variables, this points to
X * information about the hash table used
X * to implement the associative array.
X * Points to malloc-ed data. */
X Tcl_HashEntry *upvarPtr;
X /* If this is a global variable being
X * referred to in a procedure, or a variable
X * created by "upvar", this field points to
X * the hash table entry for the higher-level
X * variable. */
X } value; /* MUST BE LAST FIELD IN STRUCTURE!!! */
X} Var;
X
X/*
X * Flag bits for variables:
X *
X * VAR_ARRAY - 1 means this is an array variable rather
X * than a scalar variable.
X * VAR_UPVAR - 1 means this variable just contains a
X * pointer to another variable that has the
X * real value. Variables like this come
X * about through the "upvar" and "global"
X * commands.
X * VAR_UNDEFINED - 1 means that the variable is currently
X * undefined. Undefined variables usually
X * go away completely, but if an undefined
X * variable has a trace on it, or if it is
X * a global variable being used by a procedure,
X * then it stays around even when undefined.
X * VAR_ELEMENT_ACTIVE - Used only in array variables; 1 means that
X * an element of the array is currently being
X * manipulated in some way, so that it isn't
X * safe to delete the whole array.
X * VAR_TRACE_ACTIVE - 1 means that trace processing is currently
X * underway for a read or write access, so
X * new read or write accesses should not cause
X * trace procedures to be called and the
X * variable can't be deleted.
X */
X
X#define VAR_ARRAY 1
X#define VAR_UPVAR 2
X#define VAR_UNDEFINED 4
X#define VAR_ELEMENT_ACTIVE 0x10
X#define VAR_TRACE_ACTIVE 0x20
X#define VAR_SEARCHES_POSSIBLE 0x40
X
X/*
X *----------------------------------------------------------------
X * Data structures related to procedures. These are used primarily
X * in tclProc.c
X *----------------------------------------------------------------
X */
X
X/*
X * The structure below defines an argument to a procedure, which
X * consists of a name and an (optional) default value.
X */
X
Xtypedef struct Arg {
X struct Arg *nextPtr; /* Next argument for this procedure,
X * or NULL if this is the last argument. */
X char *defValue; /* Pointer to arg's default value, or NULL
X * if no default value. */
X char name[4]; /* Name of argument starts here. The name
X * is followed by space for the default,
X * if there is one. The actual size of this
X * field will be as large as necessary to
X * hold both name and default value. THIS
X * MUST BE THE LAST FIELD IN THE STRUCTURE!! */
X} Arg;
X
X/*
X * The structure below defines a command procedure, which consists of
X * a collection of Tcl commands plus information about arguments and
X * variables.
X */
X
Xtypedef struct Proc {
X struct Interp *iPtr; /* Interpreter for which this command
X * is defined. */
X char *command; /* Command that constitutes the body of
X * the procedure (dynamically allocated). */
X Arg *argPtr; /* Pointer to first of procedure's formal
X * arguments, or NULL if none. */
X} Proc;
X
X/*
X * The structure below defines a command trace. This is used to allow Tcl
X * clients to find out whenever a command is about to be executed.
X */
X
Xtypedef struct Trace {
X int level; /* Only trace commands at nesting level
X * less than or equal to this. */
X Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */
X ClientData clientData; /* Arbitrary value to pass to proc. */
X struct Trace *nextPtr; /* Next in list of traces for this interp. */
X} Trace;
X
X/*
X * The structure below defines a frame, which is a procedure invocation.
X * These structures exist only while procedures are being executed, and
X * provide a sort of call stack.
X */
X
Xtypedef struct CallFrame {
X Tcl_HashTable varTable; /* Hash table containing all of procedure's
X * local variables. */
X int level; /* Level of this procedure, for "uplevel"
X * purposes (i.e. corresponds to nesting of
X * callerVarPtr's, not callerPtr's). 1 means
X * outer-most procedure, 0 means top-level. */
X int argc; /* This and argv below describe name and
X * arguments for this procedure invocation. */
X char **argv; /* Array of arguments. */
X struct CallFrame *callerPtr;
X /* Frame of procedure that invoked this one
X * (NULL if level == 1). */
X struct CallFrame *callerVarPtr;
X /* Frame used by caller for accessing local
X * variables (same as callerPtr unless an
X * "uplevel" command was active in the
X * caller). This field is used in the
X * implementation of "uplevel". */
X} CallFrame;
X
X/*
X * The structure below defines one history event (a previously-executed
X * command that can be re-executed in whole or in part).
X */
X
Xtypedef struct {
X char *command; /* String containing previously-executed
X * command. */
X int bytesAvl; /* Total # of bytes available at *event (not
X * all are necessarily in use now). */
X} HistoryEvent;
X
X/*
X *----------------------------------------------------------------
X * Data structures related to history. These are used primarily
X * in tclHistory.c
X *----------------------------------------------------------------
X */
X
X/*
X * The structure below defines a pending revision to the most recent
X * history event. Changes are linked together into a list and applied
X * during the next call to Tcl_RecordHistory. See the comments at the
X * beginning of tclHistory.c for information on revisions.
X */
X
Xtypedef struct HistoryRev {
X int firstIndex; /* Index of the first byte to replace in
X * current history event. */
X int lastIndex; /* Index of last byte to replace in
X * current history event. */
X int newSize; /* Number of bytes in newBytes. */
X char *newBytes; /* Replacement for the range given by
X * firstIndex and lastIndex. */
X struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or
X * NULL for end of list. */
X} HistoryRev;
X
X/*
X *----------------------------------------------------------------
X * Data structures related to files. These are used primarily in
X * tclUnixUtil.c and tclUnixAZ.c.
X *----------------------------------------------------------------
X */
X
X/*
X * The data structure below defines an open file (or connection to
X * a process pipeline) as returned by the "open" command.
X */
X
Xtypedef struct OpenFile {
X FILE *f; /* Stdio file to use for reading and/or
X * writing. */
X FILE *f2; /* Normally NULL. In the special case of
X * a command pipeline with pipes for both
X * input and output, this is a stdio file
X * to use for writing to the pipeline. */
X int readable; /* Non-zero means file may be read. */
X int writable; /* Non-zero means file may be written. */
X int numPids; /* If this is a connection to a process
X * pipeline, gives number of processes
X * in pidPtr array below; otherwise it
X * is 0. */
X int *pidPtr; /* Pointer to malloc-ed array of child
X * process ids (numPids of them), or NULL
X * if this isn't a connection to a process
X * pipeline. */
X int errorId; /* File id of file that receives error
X * output from pipeline. -1 means not
X * used (i.e. this is a normal file). */
X} OpenFile;
X
X/*
X *----------------------------------------------------------------
X * This structure defines an interpreter, which is a collection of
X * commands plus other state information related to interpreting
X * commands, such as variable storage. Primary responsibility for
X * this data structure is in tclBasic.c, but almost every Tcl
X * source file uses something in here.
X *----------------------------------------------------------------
X */
X
Xtypedef struct Command {
X Tcl_CmdProc *proc; /* Procedure to process command. */
X ClientData clientData; /* Arbitrary value to pass to proc. */
X Tcl_CmdDeleteProc *deleteProc;
X /* Procedure to invoke when deleting
X * command. */
X} Command;
X
X#define CMD_SIZE(nameLength) ((unsigned) sizeof(Command) + nameLength - 3)
X
Xtypedef struct Interp {
X
X /*
X * Note: the first three fields must match exactly the fields in
X * a Tcl_Interp struct (see tcl.h). If you change one, be sure to
X * change the other.
X */
X
X char *result; /* Points to result returned by last
X * command. */
X Tcl_FreeProc *freeProc; /* Zero means result is statically allocated.

X * If non-zero, gives address of procedure
X * to invoke to free the result. Must be
X * freed by Tcl_Eval before executing next

X * command. */

X int errorLine; /* When TCL_ERROR is returned, this gives
X * the line number within the command where
X * the error occurred (1 means first line). */

X Tcl_HashTable commandTable; /* Contains all of the commands currently
X * registered in this interpreter. Indexed
X * by strings; values have type (Command *). */
X
X /*
X * Information related to procedures and variables. See tclProc.c
X * and tclvar.c for usage.
X */
X
X Tcl_HashTable globalTable; /* Contains all global variables for
X * interpreter. */
X int numLevels; /* Keeps track of how many nested calls to
X * Tcl_Eval are in progress for this
X * interpreter. It's used to delay deletion
X * of the table until all Tcl_Eval invocations
X * are completed. */
X CallFrame *framePtr; /* If a procedure is being executed, this
X * points to the call frame for the current
X * procedure (most recently-called). NULL
X * means no procedure is active. */
X CallFrame *varFramePtr; /* Points to the call frame whose variables
X * are currently in use (same as framePtr
X * unless an "uplevel" command is being
X * executed). NULL means no procedure is
X * active or "uplevel 0" is being exec'ed. */
X ActiveVarTrace *activeTracePtr;
X /* First in list of active traces for interp,
X * or NULL if no active traces. */
X
X /*
X * Information related to history:
X */
X
X int numEvents; /* Number of previously-executed commands
X * to retain. */
X HistoryEvent *events; /* Array containing numEvents entries
X * (dynamically allocated). */
X int curEvent; /* Index into events of place where current
X * (or most recent) command is recorded. */
X int curEventNum; /* Event number associated with the slot
X * given by curEvent. */
X HistoryRev *revPtr; /* First in list of pending revisions. */
X char *historyFirst; /* First char. of current command executed
X * from history module or NULL if none. */
X int revDisables; /* 0 means history revision OK; > 0 gives
X * a count of number of times revision has
X * been disabled. */
X char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval
X * sets this field to point to the first
X * char. of text from which the current
X * command came. Otherwise Tcl_Eval sets
X * this to NULL. */
X char *evalLast; /* Similar to evalFirst, except points to
X * last character of current command. */
X
X /*
X * Information used by Tcl_AppendResult to keep track of partial
X * results. See Tcl_AppendResult code for details.
X */
X
X char *appendResult; /* Storage space for results generated
X * by Tcl_AppendResult. Malloc-ed. NULL
X * means not yet allocated. */
X int appendAvl; /* Total amount of space available at
X * partialResult. */
X int appendUsed; /* Number of non-null bytes currently
X * stored at partialResult. */
X
X /*
X * Information related to files. See tclUnixAZ.c and tclUnixUtil.c
X * for details.
X */
X
X int numFiles; /* Number of entries in filePtrArray
X * below. 0 means array hasn't been
X * created yet. */
X OpenFile **filePtrArray; /* Pointer to malloc-ed array of pointers
X * to information about open files. Entry
X * N corresponds to the file with fileno N.
X * If an entry is NULL then the corresponding
X * file isn't open. If filePtrArray is NULL
X * it means no files have been used, so even
X * stdin/stdout/stderr entries haven't been
X * setup yet. */
X /*
X * A cache of compiled regular expressions. See TclCompileRegexp
X * in tclUtil.c for details.
X */
X
X#define NUM_REGEXPS 5
X char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled
X * regular expression patterns. NULL
X * means that this slot isn't used.
X * Malloc-ed. */
X int patLengths[NUM_REGEXPS];/* Number of non-null characters in
X * corresponding entry in patterns. */
X regexp *regexps[NUM_REGEXPS];
X /* Compiled forms of above strings. Also
X * malloc-ed, or NULL if not in use yet. */
X
X
X /*
X * Miscellaneous information:
X */
X
X int cmdCount; /* Total number of times a command procedure
X * has been called for this interpreter. */
X int noEval; /* Non-zero means no commands should actually
X * be executed: just parse only. Used in
X * expressions when the result is already
X * determined. */
X char *scriptFile; /* NULL means there is no nested source
X * command active; otherwise this points to
X * the name of the file being sourced (it's
X * not malloc-ed: it points to an argument
X * to Tcl_EvalFile. */
X int flags; /* Various flag bits. See below. */
X Trace *tracePtr; /* List of traces for this interpreter. */
X char resultSpace[TCL_RESULT_SIZE+1];
X /* Static space for storing small results. */
X} Interp;
X
X/*
X * Flag bits for Interp structures:
X *
X * DELETED: Non-zero means the interpreter has been deleted:
X * don't process any more commands for it, and destroy
X * the structure as soon as all nested invocations of
X * Tcl_Eval are done.
X * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress.
X * Zero means a command proc has been invoked since last
X * error occured.
X * ERR_ALREADY_LOGGED: Non-zero means information has already been logged
X * in $errorInfo for the current Tcl_Eval instance,
X * so Tcl_Eval needn't log it (used to implement the
X * "error message log" command).
X * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been
X * called to record information for the current
X * error. Zero means Tcl_Eval must clear the
X * errorCode variable if an error is returned.
X */
X
X#define DELETED 1
X#define ERR_IN_PROGRESS 2
X#define ERR_ALREADY_LOGGED 4
X#define ERROR_CODE_SET 8
X
X/*
X *----------------------------------------------------------------
X * Data structures related to command parsing. These are used in
X * tclParse.c and its clients.
X *----------------------------------------------------------------
X */
X
X/*
X * The following data structure is used by various parsing procedures
X * to hold information about where to store the results of parsing
X * (e.g. the substituted contents of a quoted argument, or the result
X * of a nested command). At any given time, the space available
X * for output is fixed, but a procedure may be called to expand the
X * space available if the current space runs out.
X */
X
Xtypedef struct ParseValue {
X char *buffer; /* Address of first character in
X * output buffer. */
X char *next; /* Place to store next character in
X * output buffer. */
X char *end; /* Address of the last usable character
X * in the buffer. */
X void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed));
X /* Procedure to call when space runs out;
X * it will make more space. */
X ClientData clientData; /* Arbitrary information for use of
X * expandProc. */
X} ParseValue;
X
X/*
X * A table used to classify input characters to assist in parsing
X * Tcl commands. The table should be indexed with a signed character
X * using the CHAR_TYPE macro. The character may have a negative
X * value.
X */
X
Xextern char tclTypeTable[];
X#define CHAR_TYPE(c) (tclTypeTable+128)[c]
X
X/*
X * Possible values returned by CHAR_TYPE:
X *
X * TCL_NORMAL - All characters that don't have special significance
X * to the Tcl language.
X * TCL_SPACE - Character is space, tab, or return.
X * TCL_COMMAND_END - Character is newline or null or semicolon or
X * close-bracket.
X * TCL_QUOTE - Character is a double-quote.
X * TCL_OPEN_BRACKET - Character is a "[".
X * TCL_OPEN_BRACE - Character is a "{".
X * TCL_CLOSE_BRACE - Character is a "}".
X * TCL_BACKSLASH - Character is a "\".
X * TCL_DOLLAR - Character is a "$".
X */
X
X#define TCL_NORMAL 0
X#define TCL_SPACE 1
X#define TCL_COMMAND_END 2
X#define TCL_QUOTE 3
X#define TCL_OPEN_BRACKET 4
X#define TCL_OPEN_BRACE 5
X#define TCL_CLOSE_BRACE 6
X#define TCL_BACKSLASH 7
X#define TCL_DOLLAR 8
X
X/*
X * Additional flags passed to Tcl_Eval. See tcl.h for other flags to
X * Tcl_Eval; these ones are only used internally by Tcl.
X *
X * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the
X * evalFirst and evalLast fields for each command
X * executed directly from the string (top-level
X * commands and those from command substitution).
X */
X
X#define TCL_RECORD_BOUNDS 0x100
X
X/*
X * Maximum number of levels of nesting permitted in Tcl commands.
X */
X
X#define MAX_NESTING_DEPTH 100
X
X/*
X * Macro to use instead of "void" for arguments that must have
X * type "void *" in ANSI C; maps them to type "char *" in
X * non-ANSI systems.
X */
X
X#define VOID char
X
X/*
X * Variables shared among Tcl modules but not used by the outside
X * world:
X */
X
Xextern char * tclRegexpError;
X
X/*
X *----------------------------------------------------------------
X * Procedures shared among Tcl modules but not used by the outside
X * world:
X *----------------------------------------------------------------
X */
X
Xextern void panic();
Xextern regexp * TclCompileRegexp _ANSI_ARGS_((Tcl_Interp *interp,
X char *string));
Xextern void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src,
X char *dst));
Xextern void TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
X Tcl_HashTable *tablePtr));
Xextern void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr,
X int needed));
Xextern int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp,
X char *list, char **elementPtr, char **nextPtr,
X int *sizePtr, int *bracePtr));
Xextern Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr,
X char *procName));
Xextern int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, CallFrame **framePtrPtr));
Xextern int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int *indexPtr));
Xextern int TclGetOpenFile _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, OpenFile **filePtrPtr));
Xextern Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr));
Xextern void TclMakeFileTable _ANSI_ARGS_((Interp *iPtr,
X int index));
Xextern int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, char **termPtr, ParseValue *pvPtr));
Xextern int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int flags, char **termPtr,
X ParseValue *pvPtr));
Xextern int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int termChar, int flags,
X char **termPtr, ParseValue *pvPtr));
Xextern int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, int flags, int maxWords,
X char **termPtr, int *argcPtr, char **argv,
X ParseValue *pvPtr));
Xextern void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
Xextern char * TclWordEnd _ANSI_ARGS_((char *start, int nested));
X
X/*
X *----------------------------------------------------------------
X * Command procedures in the generic core:
X *----------------------------------------------------------------
X */
X
Xextern int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));
X

X/*
X *----------------------------------------------------------------
X * Command procedures in the UNIX core:
X *----------------------------------------------------------------
X */
X
Xextern int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));

Xextern int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData,

X Tcl_Interp *interp, int argc, char **argv));
X

X#endif /* _TCLINT */
END_OF_FILE
if test 31734 -ne `wc -c <'tcl6.1/tclInt.h'`; then
echo shar: \"'tcl6.1/tclInt.h'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclInt.h'
fi
echo shar: End of archive 23 $of 33$.
cp /dev/null ark23isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:54:23 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 92
Archive-name: tcl/part24
Environment: UNIX

# "End of archive 24 (of 33)."
# Contents: tcl6.1/tclParse.c
# Wrapped by karl@one on Tue Nov 12 19:44:29 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclParse.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclParse.c'\"
else
echo shar: Extracting \"'tcl6.1/tclParse.c'\" $32623 characters$
sed "s/^X//" >'tcl6.1/tclParse.c' <<'END_OF_FILE'
X/*
X * tclParse.c --
X *
X * This file contains a collection of procedures that are used
X * to parse Tcl commands or parts of commands (like quoted
X * strings or nested sub-commands).
X *
X * Copyright 1991 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: /user6/ouster/tcl/RCS/tclParse.c,v 1.20 91/10/31 16:41:52 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The following table assigns a type to each character. Only types
X * meaningful to Tcl parsing are represented here. The table indexes
X * all 256 characters, with the negative ones first, then the positive
X * ones.
X */
X
Xchar tclTypeTable[] = {
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
X TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
X TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
X TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
X TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
X TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
X};
X
X/*
X * Function prototypes for procedures local to this file:
X */
X
Xstatic char * QuoteEnd _ANSI_ARGS_((char *string, int term));
Xstatic char * VarNameEnd _ANSI_ARGS_((char *string));

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, or 0
X * if the backslash sequence should be replace by nothing (e.g.
X * backslash followed by newline). If readPtr isn't NULL then
X * it is filled in with a count of the number of characters in
X * the backslash sequence. Note: if the backslash isn't followed
X * by characters that are understood here, then the backslash
X * sequence is only considered to be one character long, and it
X * 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 'f':
X result = '\f';
X break;
X case 'n':
X result = '\n';
X break;
X case 'r':
X result = '\r';
X break;
X case 't':
X result = '\t';
X break;
X case 'v':
X result = '\v';
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 case '\n':
X result = 0;
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 * TclParseQuotes --
X *
X * This procedure parses a double-quoted string such as a
X * quoted Tcl command argument or a quoted value in a Tcl
X * expression. This procedure is also used to parse array
X * element names within parentheses, or anything else that
X * needs all the substitutions that happen in quotes.

X *
X * Results:

X * The return value is a standard Tcl result, which is
X * TCL_OK unless there was an error while parsing the
X * quoted string. If an error occurs then interp->result
X * contains a standard error message. *TermPtr is filled
X * in with the address of the character just after the
X * last one successfully processed; this is usually the
X * character just after the matching close-quote. The
X * fully-substituted contents of the quotes are stored in
X * standard fashion in *pvPtr, null-terminated with
X * pvPtr->next pointing to the terminating null character.

X *
X * Side effects:

X * The buffer space in pvPtr may be enlarged by calling its
X * expandProc.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
X Tcl_Interp *interp; /* Interpreter to use for nested command
X * evaluations and error messages. */
X char *string; /* Character just after opening double-
X * quote. */
X int termChar; /* Character that terminates "quoted" string
X * (usually double-quote, but sometimes
X * right-paren or something else). */
X int flags; /* Flags to pass to nested Tcl_Eval calls. */
X char **termPtr; /* Store address of terminating character
X * here. */
X ParseValue *pvPtr; /* Information about where to place
X * fully-substituted result of parse. */
X{
X register char *src, *dst, c;
X
X src = string;
X dst = pvPtr->next;
X
X while (1) {
X if (dst == pvPtr->end) {
X /*
X * Target buffer space is about to run out. Make more space.
X */
X
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, 1);
X dst = pvPtr->next;
X }
X
X c = *src;
X src++;
X if (c == termChar) {
X *dst = '\0';
X pvPtr->next = dst;
X *termPtr = src;
X return TCL_OK;
X } else if (CHAR_TYPE(c) == TCL_NORMAL) {
X copy:
X *dst = c;
X dst++;
X continue;
X } else if (c == '$') {
X int length;
X char *value;
X
X value = Tcl_ParseVar(interp, src-1, termPtr);

X if (value == NULL) {
X return TCL_ERROR;
X }

X src = *termPtr;
X length = strlen(value);
X if ((pvPtr->end - dst) <= length) {
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, length);
X dst = pvPtr->next;
X }
X strcpy(dst, value);
X dst += length;
X continue;
X } else if (c == '[') {
X int result;
X
X pvPtr->next = dst;
X result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr);

X if (result != TCL_OK) {

X return result;
X }
X src = *termPtr;
X dst = pvPtr->next;
X continue;
X } else if (c == '\\') {
X int numRead;
X
X src--;
X *dst = Tcl_Backslash(src, &numRead);
X if (*dst != 0) {
X dst++;
X }
X src += numRead;
X continue;
X } else if (c == '\0') {
X Tcl_ResetResult(interp);
X sprintf(interp->result, "missing %c", termChar);
X *termPtr = string-1;
X return TCL_ERROR;
X } else {
X goto copy;
X }
X }
X}
X
X/*
X *--------------------------------------------------------------
X *
X * TclParseNestedCmd --
X *
X * This procedure parses a nested Tcl command between
X * brackets, returning the result of the command.

X *
X * Results:

X * The return value is a standard Tcl result, which is
X * TCL_OK unless there was an error while executing the
X * nested command. If an error occurs then interp->result
X * contains a standard error message. *TermPtr is filled
X * in with the address of the character just after the
X * last one processed; this is usually the character just
X * after the matching close-bracket, or the null character
X * at the end of the string if the close-bracket was missing
X * (a missing close bracket is an error). The result returned
X * by the command is stored in standard fashion in *pvPtr,
X * null-terminated, with pvPtr->next pointing to the null
X * character.

X *
X * Side effects:

X * The storage space at *pvPtr may be expanded.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
X Tcl_Interp *interp; /* Interpreter to use for nested command
X * evaluations and error messages. */
X char *string; /* Character just after opening bracket. */
X int flags; /* Flags to pass to nested Tcl_Eval. */
X char **termPtr; /* Store address of terminating character
X * here. */
X register ParseValue *pvPtr; /* Information about where to place
X * result of command. */
X{
X int result, length, shortfall;

X Interp *iPtr = (Interp *) interp;
X

X result = Tcl_Eval(interp, string, flags | TCL_BRACKET_TERM, termPtr);

X if (result != TCL_OK) {

X /*
X * The increment below results in slightly cleaner message in
X * the errorInfo variable (the close-bracket will appear).
X */
X
X if (**termPtr == ']') {
X *termPtr += 1;
X }
X return result;
X }
X (*termPtr) += 1;
X length = strlen(iPtr->result);
X shortfall = length + 1 - (pvPtr->end - pvPtr->next);
X if (shortfall > 0) {
X (*pvPtr->expandProc)(pvPtr, shortfall);
X }
X strcpy(pvPtr->next, iPtr->result);
X pvPtr->next += length;

X Tcl_FreeResult(iPtr);
X iPtr->result = iPtr->resultSpace;

X iPtr->resultSpace[0] = '\0';

X return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------

X *
X * TclParseBraces --
X *
X * This procedure scans the information between matching
X * curly braces.

X *
X * Results:

X * The return value is a standard Tcl result, which is
X * TCL_OK unless there was an error while parsing string.
X * If an error occurs then interp->result contains a
X * standard error message. *TermPtr is filled
X * in with the address of the character just after the
X * last one successfully processed; this is usually the
X * character just after the matching close-brace. The
X * information between curly braces is stored in standard
X * fashion in *pvPtr, null-terminated with pvPtr->next
X * pointing to the terminating null character.

X *
X * Side effects:

X * The storage space at *pvPtr may be expanded.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseBraces(interp, string, termPtr, pvPtr)
X Tcl_Interp *interp; /* Interpreter to use for nested command
X * evaluations and error messages. */
X char *string; /* Character just after opening bracket. */
X char **termPtr; /* Store address of terminating character
X * here. */
X register ParseValue *pvPtr; /* Information about where to place
X * result of command. */
X{
X int level;
X register char *src, *dst, *end;

X register char c;
X

X src = string;
X dst = pvPtr->next;
X end = pvPtr->end;
X level = 1;
X
X /*
X * Copy the characters one at a time to the result area, stopping
X * when the matching close-brace is found.
X */
X
X while (1) {
X c = *src;
X src++;
X if (dst == end) {
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, 20);
X dst = pvPtr->next;
X end = pvPtr->end;
X }
X *dst = c;
X dst++;
X if (CHAR_TYPE(c) == TCL_NORMAL) {
X continue;
X } else if (c == '{') {
X level++;
X } else if (c == '}') {
X level--;

X if (level == 0) {

X dst--; /* Don't copy the last close brace. */
X break;
X }
X } else if (c == '\\') {
X int count;
X
X /*
X * Must always squish out backslash-newlines, even when in
X * braces. This is needed so that this sequence can appear
X * anywhere in a command, such as the middle of an expression.
X */
X

X if (*src == '\n') {

X dst--;
X src++;
X } else {
X (void) Tcl_Backslash(src-1, &count);
X while (count > 1) {
X if (dst == end) {
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, 20);
X dst = pvPtr->next;
X end = pvPtr->end;
X }
X *dst = *src;
X dst++;
X src++;
X count--;
X }
X }
X } else if (c == '\0') {
X Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
X *termPtr = string-1;

X return TCL_ERROR;
X }
X }
X

X *dst = '\0';
X pvPtr->next = dst;
X *termPtr = src;

X return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------

X *
X * TclParseWords --
X *
X * This procedure parses one or more words from a command
X * string and creates argv-style pointers to fully-substituted
X * copies of those words.

X *
X * Results:

X * The return value is a standard Tcl result.
X *
X * *argcPtr is modified to hold a count of the number of words
X * successfully parsed, which may be 0. At most maxWords words
X * will be parsed. If 0 <= *argcPtr < maxWords then it
X * means that a command separator was seen. If *argcPtr
X * is maxWords then it means that a command separator was
X * not seen yet.
X *
X * *TermPtr is filled in with the address of the character
X * just after the last one successfully processed in the
X * last word. This is either the command terminator (if
X * *argcPtr < maxWords), the character just after the last
X * one in a word (if *argcPtr is maxWords), or the vicinity
X * of an error (if the result is not TCL_OK).
X *
X * The pointers at *argv are filled in with pointers to the
X * fully-substituted words, and the actual contents of the
X * words are copied to the buffer at pvPtr.
X *
X * If an error occurrs then an error message is left in
X * interp->result and the information at *argv, *argcPtr,
X * and *pvPtr may be incomplete.

X *
X * Side effects:

X * The buffer space in pvPtr may be enlarged by calling its
X * expandProc.
X *
X *--------------------------------------------------------------
X */
X
Xint
XTclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr)
X Tcl_Interp *interp; /* Interpreter to use for nested command
X * evaluations and error messages. */
X char *string; /* First character of word. */
X int flags; /* Flags to control parsing (same values as
X * passed to Tcl_Eval). */
X int maxWords; /* Maximum number of words to parse. */
X char **termPtr; /* Store address of terminating character
X * here. */
X int *argcPtr; /* Filled in with actual number of words
X * parsed. */
X char **argv; /* Store addresses of individual words here. */
X register ParseValue *pvPtr; /* Information about where to place
X * fully-substituted word. */
X{
X register char *src, *dst;
X register char c;
X int type, result, argc;
X char *oldBuffer; /* Used to detect when pvPtr's buffer gets
X * reallocated, so we can adjust all of the
X * argv pointers. */
X
X src = string;
X oldBuffer = pvPtr->buffer;
X dst = pvPtr->next;
X for (argc = 0; argc < maxWords; argc++) {
X argv[argc] = dst;
X
X /*
X * Skip leading space.
X */
X
X skipSpace:
X c = *src;
X type = CHAR_TYPE(c);
X while (type == TCL_SPACE) {
X src++;
X c = *src;
X type = CHAR_TYPE(c);
X }
X
X /*
X * Handle the normal case (i.e. no leading double-quote or brace).
X */
X
X if (type == TCL_NORMAL) {
X normalArg:
X while (1) {
X if (dst == pvPtr->end) {
X /*
X * Target buffer space is about to run out. Make
X * more space.
X */
X
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, 1);
X dst = pvPtr->next;
X }
X
X if (type == TCL_NORMAL) {
X copy:
X *dst = c;
X dst++;
X src++;
X } else if (type == TCL_SPACE) {
X goto wordEnd;
X } else if (type == TCL_DOLLAR) {
X int length;
X char *value;
X
X value = Tcl_ParseVar(interp, src, termPtr);

X if (value == NULL) {
X return TCL_ERROR;
X }

X src = *termPtr;
X length = strlen(value);
X if ((pvPtr->end - dst) <= length) {
X pvPtr->next = dst;
X (*pvPtr->expandProc)(pvPtr, length);
X dst = pvPtr->next;
X }
X strcpy(dst, value);
X dst += length;
X } else if (type == TCL_COMMAND_END) {
X if ((c == ']') && !(flags & TCL_BRACKET_TERM)) {
X goto copy;
X }
X
X /*
X * End of command; simulate a word-end first, so
X * that the end-of-command can be processed as the
X * first thing in a new word.
X */
X
X goto wordEnd;
X } else if (type == TCL_OPEN_BRACKET) {
X pvPtr->next = dst;
X result = TclParseNestedCmd(interp, src+1, flags, termPtr,
X pvPtr);

X if (result != TCL_OK) {

X return result;
X }
X src = *termPtr;
X dst = pvPtr->next;
X } else if (type == TCL_BACKSLASH) {
X int numRead;
X
X *dst = Tcl_Backslash(src, &numRead);
X if (*dst != 0) {
X dst++;
X }
X src += numRead;
X } else {
X goto copy;
X }
X c = *src;
X type = CHAR_TYPE(c);
X }
X } else {
X
X /*
X * Check for the end of the command.
X */
X
X if (type == TCL_COMMAND_END) {

X if (flags & TCL_BRACKET_TERM) {

X if (c == '\0') {
X Tcl_SetResult(interp, "missing close-bracket",
X TCL_STATIC);
X return TCL_ERROR;
X }
X } else {
X if (c == ']') {
X goto normalArg;
X }
X }
X goto done;
X }
X
X /*
X * Now handle the special cases: open braces, double-quotes,
X * and backslash-newline.
X */
X
X pvPtr->next = dst;
X if (type == TCL_QUOTE) {
X result = TclParseQuotes(interp, src+1, '"', flags,
X termPtr, pvPtr);
X } else if (type == TCL_OPEN_BRACE) {
X result = TclParseBraces(interp, src+1, termPtr, pvPtr);
X } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) {
X src += 2;
X goto skipSpace;
X } else {
X goto normalArg;
X }

X if (result != TCL_OK) {
X return result;

X }
X
X /*
X * Back from quotes or braces; make sure that the terminating
X * character was the end of the word. Have to be careful here
X * to handle continuation lines (i.e. lines ending in backslash).
X */
X
X c = **termPtr;
X if ((c == '\\') && ((*termPtr)[1] == '\n')) {
X c = (*termPtr)[2];
X }
X type = CHAR_TYPE(c);
X if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
X if (*src == '"') {
X Tcl_SetResult(interp, "extra characters after close-quote",
X TCL_STATIC);
X } else {
X Tcl_SetResult(interp, "extra characters after close-brace",
X TCL_STATIC);
X }
X return TCL_ERROR;
X }
X src = *termPtr;
X dst = pvPtr->next;
X
X }
X
X /*
X * We're at the end of a word, so add a null terminator. Then
X * see if the buffer was re-allocated during this word. If so,
X * update all of the argv pointers.
X */
X
X wordEnd:
X *dst = '\0';
X dst++;
X if (oldBuffer != pvPtr->buffer) {
X int i;
X
X for (i = 0; i <= argc; i++) {
X argv[i] = pvPtr->buffer + (argv[i] - oldBuffer);
X }
X oldBuffer = pvPtr->buffer;
X }
X }
X
X done:
X pvPtr->next = dst;
X *termPtr = src;
X *argcPtr = argc;

X return TCL_OK;
X}
X
X/*
X *--------------------------------------------------------------

X *
X * TclExpandParseValue --
X *
X * This procedure is commonly used as the value of the
X * expandProc in a ParseValue. It uses malloc to allocate
X * more space for the result of a parse.

X *
X * Results:

X * The buffer space in *pvPtr is reallocated to something
X * larger, and if pvPtr->clientData is non-zero the old
X * buffer is freed. Information is copied from the old
X * buffer to the new one.

X *
X * Side effects:
X * None.
X *
X *--------------------------------------------------------------

X */
X
Xvoid
XTclExpandParseValue(pvPtr, needed)
X register ParseValue *pvPtr; /* Information about buffer that
X * must be expanded. If the clientData
X * in the structure is non-zero, it
X * means that the current buffer is
X * dynamically allocated. */
X int needed; /* Minimum amount of additional space
X * to allocate. */
X{
X int newSpace;
X char *new;
X
X /*
X * Either double the size of the buffer or add enough new space
X * to meet the demand, whichever produces a larger new buffer.
X */
X
X newSpace = (pvPtr->end - pvPtr->buffer) + 1;
X if (newSpace < needed) {
X newSpace += needed;
X } else {
X newSpace += newSpace;
X }
X new = (char *) ckalloc((unsigned) newSpace);
X
X /*
X * Copy from old buffer to new, free old buffer if needed, and
X * mark new buffer as malloc-ed.
X */
X
X memcpy((VOID *) new, (VOID *) pvPtr->buffer, pvPtr->next - pvPtr->buffer);
X pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
X if (pvPtr->clientData != 0) {
X ckfree(pvPtr->buffer);
X }
X pvPtr->buffer = new;
X pvPtr->end = new + newSpace - 1;
X pvPtr->clientData = (ClientData) 1;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * TclWordEnd --
X *
X * Given a pointer into a Tcl command, find the end of the next
X * word of the command.

X *
X * Results:

X * The return value is a pointer to the character just after the
X * last one that's part of the word pointed to by "start". This
X * may be the address of the NULL character at the end of the
X * string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTclWordEnd(start, nested)
X char *start; /* Beginning of a word of a Tcl command. */
X int nested; /* Zero means this is a top-level command.
X * One means this is a nested command (close
X * brace is a word terminator). */
X{
X register char *p;
X int count;
X
X p = start;
X while (isspace(*p)) {
X p++;
X }
X
X /*
X * Handle words beginning with a double-quote or a brace.
X */
X
X if (*p == '"') {
X p = QuoteEnd(p+1, '"');

X } else if (*p == '{') {

X int braces = 1;
X while (braces != 0) {
X p++;
X while (*p == '\\') {
X (void) Tcl_Backslash(p, &count);

X p += count;
X }

X if (*p == '}') {
X braces--;

X } else if (*p == '{') {

X braces++;
X } else if (*p == 0) {
X return p;
X }
X }
X }
X
X /*
X * Handle words that don't start with a brace or double-quote.
X * This code is also invoked if the word starts with a brace or
X * double-quote and there is garbage after the closing brace or
X * quote. This is an error as far as Tcl_Eval is concerned, but
X * for here the garbage is treated as part of the word.
X */
X
X while (*p != 0) {
X if (*p == '[') {
X p++;
X while ((*p != ']') && (*p != 0)) {
X p = TclWordEnd(p, 1);
X }
X if (*p == ']') {
X p++;
X }

X } else if (*p == '\\') {

X (void) Tcl_Backslash(p, &count);
X p += count;
X } else if (*p == '$') {
X p = VarNameEnd(p);
X } else if (*p == ';') {
X /*
X * Note: semi-colon terminates a word
X * and also counts as a word by itself.
X */
X
X if (p == start) {
X p++;
X }
X break;
X } else if (isspace(*p)) {
X break;
X } else if ((*p == ']') && nested) {
X break;
X } else {
X p++;
X }
X }
X return p;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * QuoteEnd --
X *
X * Given a pointer to a string that obeys the parsing conventions
X * for quoted things in Tcl, find the end of that quoted thing.
X * The actual thing may be a quoted argument or a parenthesized
X * index name.

X *
X * Results:

X * The return value is a pointer to the character just after the
X * last one that is part of the quoted string.
X *

X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic char *
XQuoteEnd(string, term)
X char *string; /* Pointer to character just after opening
X * "quote". */
X int term; /* This character will terminate the
X * quoted string (e.g. '"' or ')'). */
X{
X register char *p = string;
X int count;
X
X while ((*p != 0) && (*p != term)) {
X if (*p == '\\') {
X (void) Tcl_Backslash(p, &count);
X p += count;

X } else if (*p == '[') {

X p++;
X while ((*p != ']') && (*p != 0)) {
X p = TclWordEnd(p, 1);
X }
X if (*p == ']') {
X p++;
X }
X } else if (*p == '$') {
X p = VarNameEnd(p);
X } else {
X p++;
X }
X }
X return p;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * VarNameEnd --
X *
X * Given a pointer to a variable reference using $-notation, find
X * the end of the variable name spec.

X *
X * Results:

X * The return value is a pointer to the character just after the
X * last one that is part of the variable name.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic char *
XVarNameEnd(string)
X char *string; /* Pointer to dollar-sign character. */
X{
X register char *p = string+1;
X
X if (*p == '{') {
X do {
X p++;
X } while ((*p != '}') && (*p != 0));
X } else {
X while (isalnum(*p) || (*p == '_')) {
X p++;
X }
X if ((*p == '(') && (p != string+1)) {
X p = QuoteEnd(p+1, ')');
X }
X }
X return p;
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 *name1, *name1End, c, *result;
X register char *name2;
X#define NUM_CHARS 200

X char copyStorage[NUM_CHARS];
X ParseValue pv;

X
X /*
X * There are three 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, and the
X * variable is a scalar variable.
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. If the following character is an
X * open parenthesis, then the information between parentheses is
X * the array element name, which can include any of the substitutions
X * permissible between quotes.
X * 3. The $ sign is followed by something that isn't a letter, digit,
X * or underscore: in this case, there is no variable name, and "$"
X * is returned.
X */
X
X name2 = NULL;
X string++;
X if (*string == '{') {
X string++;
X name1 = string;
X while (*string != '}') {
X if (*string == 0) {
X Tcl_SetResult(interp, "missing close-brace for variable name",
X TCL_STATIC);
X return NULL;
X }
X string++;
X }
X name1End = string;
X string++;
X } else {
X name1 = string;
X while (isalnum(*string) || (*string == '_')) {
X string++;
X }
X if (string == name1) {
X if (termPtr != 0) {
X *termPtr = string;
X }
X return "$";
X }
X name1End = string;
X if (*string == '(') {
X char *end;
X
X /*
X * Perform substitutions on the array element name, just as
X * is done for quotes.
X */
X
X pv.buffer = pv.next = copyStorage;

X pv.end = copyStorage + NUM_CHARS - 1;
X pv.expandProc = TclExpandParseValue;
X pv.clientData = (ClientData) NULL;

X if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
X != TCL_OK) {
X char msg[100];
X sprintf(msg, "\n (parsing index for array \"%.*s\")",
X string-name1, name1);
X Tcl_AddErrorInfo(interp, msg);
X result = NULL;
X name2 = pv.buffer;
X goto done;
X }
X string = end;
X name2 = pv.buffer;
X }
X }
X if (termPtr != 0) {
X *termPtr = string;
X }
X
X c = *name1End;
X *name1End = 0;
X result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
X *name1End = c;
X
X done:
X if ((name2 != NULL) && (pv.buffer != copyStorage)) {
X ckfree(pv.buffer);

X }
X return result;
X}

END_OF_FILE
if test 32623 -ne `wc -c <'tcl6.1/tclParse.c'`; then
echo shar: \"'tcl6.1/tclParse.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclParse.c'
fi
echo shar: End of archive 24 $of 33$.
cp /dev/null ark24isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:55:10 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 93
Archive-name: tcl/part25
Environment: UNIX

# "End of archive 25 (of 33)."
# Contents: tcl6.1/tclVar.c.1
# Wrapped by karl@one on Tue Nov 12 19:44:29 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclVar.c.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclVar.c.1'\"
else
echo shar: Extracting \"'tcl6.1/tclVar.c.1'\" $32992 characters$
sed "s/^X//" >'tcl6.1/tclVar.c.1' <<'END_OF_FILE'
X/*
X * tclVar.c --
X *
X * This file contains routines that implement Tcl variables
X * (both scalars and arrays).
X *
X * The implementation of arrays is modelled after an initial
X * implementation by Karl Lehenbauer, Mark Diekhans and
X * Peter da Silva.
X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclVar.c,v 1.25 91/10/31 16:41:46 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The strings below are used to indicate what went wrong when a
X * variable access is denied.
X */
X
Xstatic char *noSuchVar = "no such variable";
Xstatic char *isArray = "variable is array";
Xstatic char *needArray = "variable isn't array";
Xstatic char *noSuchElement = "no such element in array";
Xstatic char *traceActive = "trace is active on variable";
X
X/*
X * Forward references to procedures defined later in this file:
X */
X
Xstatic char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
X Tcl_HashEntry *hPtr, char *name1, char *name2,
X int flags));
Xstatic void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
Xstatic void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
X Var *varPtr, int flags));
Xstatic Var * NewVar _ANSI_ARGS_((int space));
Xstatic ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
X Var *varPtr, char *varName, char *string));
Xstatic void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
X char *name1, char *name2, char *operation,
X char *reason));

X
X/*
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 or can't be read because of a clash
X * in array usage then a NULL pointer is returned and an error
X * message is left in interp->result if the TCL_LEAVE_ERR_MSG
X * flag is set. Note: the return value is only valid up until
X * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on
X * the value lasting longer than that, then make yourself a private
X * copy.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_GetVar(interp, varName, flags)
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 flags; /* OR-ed combination of TCL_GLOBAL_ONLY
X * or TCL_LEAVE_ERR_MSG bits. */
X{
X register char *p;
X
X /*
X * If varName refers to an array (it ends with a parenthesized
X * element name), then handle it specially.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X char *result;
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X result = Tcl_GetVar2(interp, varName, open+1, flags);
X *open = '(';
X *p = ')';

X return result;
X }
X }
X

X scalar:
X return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GetVar2 --
X *
X * Return the value of a Tcl variable, given a two-part name
X * consisting of array name and element within array.

X *
X * Results:

X * The return value points to the current value of the variable
X * given by name1 and name2. If the specified variable doesn't
X * exist, or if there is a clash in array usage, then NULL is
X * returned and a message will be left in interp->result if the
X * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is
X * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
X * if you depend on the value lasting longer than that, then make
X * yourself a private copy.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_GetVar2(interp, name1, name2, flags)
X Tcl_Interp *interp; /* Command interpreter in which variable is
X * to be looked up. */
X char *name1; /* Name of array (if name2 is NULL) or
X * name of variable. */
X char *name2; /* If non-null, gives name of element in
X * array. */
X int flags; /* OR-ed combination of TCL_GLOBAL_ONLY
X * or TCL_LEAVE_ERR_MSG bits. */
X{

X Tcl_HashEntry *hPtr;
X Var *varPtr;

X Interp *iPtr = (Interp *) interp;

X Var *arrayPtr = NULL;
X
X /*
X * Lookup the first name.
X */
X

X if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X } else {
X hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
X }
X if (hPtr == NULL) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "read", noSuchVar);
X }
X return NULL;
X }

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X hPtr = varPtr->value.upvarPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * If this is an array reference, then remember the traces on the array
X * and lookup the element within the array.
X */
X

X if (name2 != NULL) {

X if (varPtr->flags & VAR_UNDEFINED) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "read", noSuchVar);
X }
X return NULL;
X } else if (!(varPtr->flags & VAR_ARRAY)) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "read", needArray);
X }
X return NULL;
X }
X arrayPtr = varPtr;

X hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X if (hPtr == NULL) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "read", noSuchElement);
X }
X return NULL;
X }

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * Invoke any traces that have been set for the variable.
X */
X
X if ((varPtr->tracePtr != NULL)
X || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X char *msg;
X
X msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
X (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
X if (msg != NULL) {
X VarErrMsg(interp, name1, name2, "read", msg);

X return NULL;
X }
X

X /*
X * Watch out! The variable could have gotten re-allocated to
X * a larger size. Fortunately the hash table entry will still
X * be around.

X */
X
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X }

X if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "read", noSuchVar);
X }
X return NULL;
X }
X return varPtr->value.string;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SetVar --
X *
X * Change the value of a variable.

X *
X * Results:

X * Returns a pointer to the malloc'ed string holding the new
X * value of the variable. The caller should not modify this
X * string. If the write operation was disallowed then NULL
X * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then
X * an explanatory message will be left in interp->result.

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
Xchar *

XTcl_SetVar(interp, varName, newValue, flags)
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 flags; /* Various flags that tell how to set value:
X * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
X * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
X * TCL_LEAVE_ERR_MSG. */
X{
X register char *p;
X
X /*
X * If varName refers to an array (it ends with a parenthesized
X * element name), then handle it specially.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X char *result;
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
X *open = '(';
X *p = ')';

X return result;
X }
X }
X

X scalar:
X return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SetVar2 --
X *
X * Given a two-part variable name, which may refer either to a
X * scalar variable or an element of an array, change the value
X * of the variable. If the named scalar or array or element
X * doesn't exist then create one.

X *
X * Results:

X * Returns a pointer to the malloc'ed string holding the new
X * value of the variable. The caller should not modify this
X * string. If the write operation was disallowed because an
X * array was expected but not found (or vice versa), then NULL
X * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then
X * an explanatory message will be left in interp->result.

X *
X * Side effects:

X * The value of the given variable is set. If either the array
X * or the entry didn't exist then a new one is created.

X *
X *----------------------------------------------------------------------
X */
X
Xchar *

XTcl_SetVar2(interp, name1, name2, newValue, flags)
X Tcl_Interp *interp; /* Command interpreter in which variable is
X * to be looked up. */
X char *name1; /* If name2 is NULL, this is name of scalar
X * variable. Otherwise it is name of array. */
X char *name2; /* Name of an element within array, or NULL. */
X char *newValue; /* New value for variable. */
X int flags; /* Various flags that tell how to set value:
X * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
X * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
X * TCL_LEAVE_ERR_MSG . */
X{
X Tcl_HashEntry *hPtr;
X register Var *varPtr = NULL;
X /* Initial value only used to stop compiler
X * from complaining; not really needed. */
X register Interp *iPtr = (Interp *) interp;
X int length, new, listFlags;
X Var *arrayPtr = NULL;
X
X /*
X * Lookup the first name.
X */
X

X if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {

X hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
X } else {
X hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
X name1, &new);
X }
X if (!new) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X hPtr = varPtr->value.upvarPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X }
X
X /*

X * If this is an array reference, then create a new array (if
X * needed), remember any traces on the array, and lookup the
X * element within the array.
X */
X

X if (name2 != NULL) {

X if (new) {
X varPtr = NewVar(0);
X Tcl_SetHashValue(hPtr, varPtr);
X varPtr->flags = VAR_ARRAY;
X varPtr->value.tablePtr = (Tcl_HashTable *)
X ckalloc(sizeof(Tcl_HashTable));
X Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X } else {
X if (varPtr->flags & VAR_UNDEFINED) {
X varPtr->flags = VAR_ARRAY;
X varPtr->value.tablePtr = (Tcl_HashTable *)
X ckalloc(sizeof(Tcl_HashTable));
X Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X } else if (!(varPtr->flags & VAR_ARRAY)) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "set", needArray);
X }
X return NULL;
X }
X arrayPtr = varPtr;
X }
X hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
X }
X
X /*
X * Compute how many bytes will be needed for newValue (leave space
X * for a separating space between list elements).
X */
X
X if (flags & TCL_LIST_ELEMENT) {
X length = Tcl_ScanElement(newValue, &listFlags) + 1;
X } else {
X length = strlen(newValue);
X }
X
X /*
X * If the variable doesn't exist then create a new one. If it
X * does exist then clear its current value unless this is an
X * append operation.
X */
X
X if (new) {
X varPtr = NewVar(length);
X Tcl_SetHashValue(hPtr, varPtr);
X if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
X DeleteSearches(arrayPtr);
X }
X } else {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X if (varPtr->flags & VAR_ARRAY) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "set", isArray);
X }
X return NULL;
X }
X if (!(flags & TCL_APPEND_VALUE)) {

X varPtr->valueLength = 0;

X }
X }
X
X /*

X * Make sure there's enough space to hold the variable's
X * new value. If not, enlarge the variable's space.
X */
X
X if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
X Var *newVarPtr;
X int newSize;
X
X newSize = 2*varPtr->valueSpace;
X if (newSize <= (length + varPtr->valueLength)) {
X newSize += length;
X }
X newVarPtr = NewVar(newSize);
X newVarPtr->valueLength = varPtr->valueLength;
X newVarPtr->upvarUses = varPtr->upvarUses;
X newVarPtr->tracePtr = varPtr->tracePtr;
X strcpy(newVarPtr->value.string, varPtr->value.string);
X Tcl_SetHashValue(hPtr, newVarPtr);
X ckfree((char *) varPtr);
X varPtr = newVarPtr;
X }
X
X /*
X * Append the new value to the variable, either as a list
X * element or as a string.
X */
X
X if (flags & TCL_LIST_ELEMENT) {
X if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
X varPtr->value.string[varPtr->valueLength] = ' ';
X varPtr->valueLength++;
X }
X varPtr->valueLength += Tcl_ConvertElement(newValue,
X varPtr->value.string + varPtr->valueLength, listFlags);
X varPtr->value.string[varPtr->valueLength] = 0;
X } else {
X strcpy(varPtr->value.string + varPtr->valueLength, newValue);
X varPtr->valueLength += length;
X }
X varPtr->flags &= ~VAR_UNDEFINED;
X
X /*
X * Invoke any write traces for the variable.
X */
X
X if ((varPtr->tracePtr != NULL)
X || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X char *msg;
X
X msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
X (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
X if (msg != NULL) {
X VarErrMsg(interp, name1, name2, "set", msg);

X return NULL;
X }
X

X /*
X * Watch out! The variable could have gotten re-allocated to
X * a larger size. Fortunately the hash table entry will still
X * be around.

X */
X
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X }

X return varPtr->value.string;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UnsetVar --
X *
X * Delete a variable, so that it may not be accessed anymore.

X *
X * Results:

X * Returns 0 if the variable was successfully deleted, -1
X * if the variable can't be unset. In the event of an error,
X * if the TCL_LEAVE_ERR_MSG flag is set then an error message
X * is left in interp->result.

X *
X * Side effects:

X * If varName is defined as a local or global variable in interp,
X * it is deleted.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_UnsetVar(interp, varName, flags)
X Tcl_Interp *interp; /* Command interpreter in which varName is
X * to be looked up. */
X char *varName; /* Name of a variable in interp. May be
X * either a scalar name or an array name
X * or an element in an array. */
X int flags; /* OR-ed combination of any of
X * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
X{
X register char *p;
X int result;
X
X /*
X * Figure out whether this is an array reference, then call
X * Tcl_UnsetVar2 to do all the real work.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X result = Tcl_UnsetVar2(interp, varName, open+1, flags);
X *open = '(';
X *p = ')';

X return result;
X }
X }
X

X scalar:
X return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UnsetVar2 --
X *
X * Delete a variable, given a 2-part name.

X *
X * Results:

X *
X * Side effects:

X * If name1 and name2 indicate a local or global variable in interp,
X * it is deleted. If name1 is an array name and name2 is NULL, then
X * the whole array is deleted.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_UnsetVar2(interp, name1, name2, flags)
X Tcl_Interp *interp; /* Command interpreter in which varName is
X * to be looked up. */

X char *name1; /* Name of variable or array. */

X char *name2; /* Name of element within array or NULL. */
X int flags; /* OR-ed combination of any of
X * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
X{
X Tcl_HashEntry *hPtr, dummyEntry;
X Var *varPtr, dummyVar;

X Interp *iPtr = (Interp *) interp;

X Var *arrayPtr = NULL;

X
X if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X } else {
X hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
X }
X if (hPtr == NULL) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "unset", noSuchVar);
X }
X return -1;

X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X
X /*
X * For global variables referenced in procedures, leave the procedure's
X * reference variable in place, but unset the global variable. Can't
X * decrement the actual variable's use count, since we didn't delete
X * the reference variable.
X */
X

X if (varPtr->flags & VAR_UPVAR) {
X hPtr = varPtr->value.upvarPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * If the variable being deleted is an element of an array, then
X * remember trace procedures on the overall array and find the
X * element to delete.
X */
X

X if (name2 != NULL) {
X if (!(varPtr->flags & VAR_ARRAY)) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "unset", needArray);
X }
X return -1;
X }
X if (varPtr->searchPtr != NULL) {
X DeleteSearches(varPtr);
X }
X arrayPtr = varPtr;

X hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X if (hPtr == NULL) {

X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "unset", noSuchElement);
X }
X return -1;

X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * If there is a trace active on this variable or if the variable
X * is already being deleted then don't delete the variable: it
X * isn't safe, since there are procedures higher up on the stack
X * that will use pointers to the variable. Also don't delete an
X * array if there are traces active on any of its elements.
X */
X
X if (varPtr->flags &
X (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "unset", traceActive);
X }
X return -1;
X }
X
X /*
X * The code below is tricky, because of the possibility that
X * a trace procedure might try to access a variable being
X * deleted. To handle this situation gracefully, copy the
X * contents of the variable and its hash table entry to
X * dummy variables, then clean up the actual variable so that
X * it's been completely deleted before the traces are called.
X * Then call the traces, and finally clean up the variable's
X * storage using the dummy copies.
X */
X
X dummyVar = *varPtr;
X Tcl_SetHashValue(&dummyEntry, &dummyVar);
X if (varPtr->upvarUses == 0) {
X Tcl_DeleteHashEntry(hPtr);
X ckfree((char *) varPtr);
X } else {
X varPtr->flags = VAR_UNDEFINED;

X varPtr->tracePtr = NULL;

X }
X
X /*
X * Call trace procedures for the variable being deleted and delete
X * its traces.
X */
X
X if ((dummyVar.tracePtr != NULL)
X || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X (void) CallTraces(iPtr, arrayPtr, &dummyEntry, name1, name2,
X (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
X while (dummyVar.tracePtr != NULL) {
X VarTrace *tracePtr = dummyVar.tracePtr;
X dummyVar.tracePtr = tracePtr->nextPtr;
X ckfree((char *) tracePtr);

X }
X }
X
X /*

X * If the variable is an array, delete all of its elements. This
X * must be done after calling the traces on the array, above (that's
X * the way traces are defined).
X */
X
X if (dummyVar.flags & VAR_ARRAY) {
X DeleteArray(iPtr, name1, &dummyVar,
X (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
X }
X if (dummyVar.flags & VAR_UNDEFINED) {
X if (flags & TCL_LEAVE_ERR_MSG) {
X VarErrMsg(interp, name1, name2, "set",
X (name2 != NULL) ? noSuchVar : noSuchElement);
X }
X return -1;

X }
X return 0;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_TraceVar --
X *
X * Arrange for reads and/or writes to a variable to cause a
X * procedure to be invoked, which can monitor the operations
X * and/or change their actions.

X *
X * Results:

X * A standard Tcl return value.

X *
X * Side effects:

X * A trace is set up on the variable given by varName, such that
X * future references to the variable will be intermediated by
X * proc. See the manual entry for complete details on the calling
X * sequence for proc.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_TraceVar(interp, varName, flags, proc, clientData)
X Tcl_Interp *interp; /* Interpreter in which variable is
X * to be traced. */
X char *varName; /* Name of variable; may end with "(index)"
X * to signify an array reference. */
X int flags; /* OR-ed collection of bits, including any
X * of TCL_TRACE_READS, TCL_TRACE_WRITES,
X * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
X * invoked upon varName. */
X ClientData clientData; /* Arbitrary argument to pass to proc. */
X{
X register char *p;
X
X /*
X * If varName refers to an array (it ends with a parenthesized
X * element name), then handle it specially.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X int result;
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X result = Tcl_TraceVar2(interp, varName, open+1, flags,
X proc, clientData);
X *open = '(';
X *p = ')';

X return result;
X }
X }
X

X scalar:
X return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
X proc, clientData);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_TraceVar2 --
X *
X * Arrange for reads and/or writes to a variable to cause a
X * procedure to be invoked, which can monitor the operations
X * and/or change their actions.

X *
X * Results:

X * A standard Tcl return value.

X *
X * Side effects:

X * A trace is set up on the variable given by name1 and name2, such
X * that future references to the variable will be intermediated by
X * proc. See the manual entry for complete details on the calling
X * sequence for proc.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
X Tcl_Interp *interp; /* Interpreter in which variable is
X * to be traced. */
X char *name1; /* Name of scalar variable or array. */

X char *name2; /* Name of element within array; NULL means
X * trace applies to scalar variable or array

X * as-a-whole. */
X int flags; /* OR-ed collection of bits, including any
X * of TCL_TRACE_READS, TCL_TRACE_WRITES,
X * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
X * invoked upon varName. */
X ClientData clientData; /* Arbitrary argument to pass to proc. */
X{
X Tcl_HashEntry *hPtr;
X Var *varPtr = NULL; /* Initial value only used to stop compiler
X * from complaining; not really needed. */

X Interp *iPtr = (Interp *) interp;

X register VarTrace *tracePtr;
X int new;
X
X /*
X * Locate the variable, making a new (undefined) one if necessary.
X */
X

X if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {

X hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
X } else {
X hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, name1, &new);
X }
X if (!new) {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X hPtr = varPtr->value.upvarPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X }
X
X /*

X * If the trace is to be on an array element, make sure that the
X * variable is an array variable. If the variable doesn't exist
X * then define it as an empty array. Then find the specific
X * array element.
X */
X

X if (name2 != NULL) {

X return TCL_ERROR;
X }
X }

X hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
X }
X
X if (new) {
X if ((name2 != NULL) && (varPtr->searchPtr != NULL)) {
X DeleteSearches(varPtr);

X }
X varPtr = NewVar(0);

X varPtr->flags = VAR_UNDEFINED;
X Tcl_SetHashValue(hPtr, varPtr);
X } else {

X varPtr = (Var *) Tcl_GetHashValue(hPtr);

X }
X
X /*
X * Set up trace information.
X */
X
X tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
X tracePtr->traceProc = proc;

X tracePtr->clientData = clientData;

X tracePtr->flags = flags &
X (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
X tracePtr->nextPtr = varPtr->tracePtr;
X varPtr->tracePtr = tracePtr;
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UntraceVar --
X *
X * Remove a previously-created trace for a variable.

X *
X * Results:
X * None.
X *
X * Side effects:

X * If there exists a trace for the variable given by varName
X * with the given flags, proc, and clientData, then that trace
X * is removed.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_UntraceVar(interp, varName, flags, proc, clientData)
X Tcl_Interp *interp; /* Interpreter containing traced variable. */
X char *varName; /* Name of variable; may end with "(index)"
X * to signify an array reference. */
X int flags; /* OR-ed collection of bits describing
X * current trace, including any of
X * TCL_TRACE_READS, TCL_TRACE_WRITES,
X * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
X ClientData clientData; /* Arbitrary argument to pass to proc. */
X{
X register char *p;
X
X /*
X * If varName refers to an array (it ends with a parenthesized
X * element name), then handle it specially.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
X *open = '(';
X *p = ')';

X return;
X }
X }
X

X scalar:
X Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_UntraceVar2 --
X *
X * Remove a previously-created trace for a variable.

X *
X * Results:
X * None.
X *
X * Side effects:

X * If there exists a trace for the variable given by name1
X * and name2 with the given flags, proc, and clientData, then
X * that trace is removed.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
X Tcl_Interp *interp; /* Interpreter containing traced variable. */

X char *name1; /* Name of variable or array. */
X char *name2; /* Name of element within array; NULL means
X * trace applies to scalar variable or array

X * as-a-whole. */
X int flags; /* OR-ed collection of bits describing
X * current trace, including any of
X * TCL_TRACE_READS, TCL_TRACE_WRITES,
X * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
X ClientData clientData; /* Arbitrary argument to pass to proc. */

X{
X register VarTrace *tracePtr;

X VarTrace *prevPtr;
X Var *varPtr;

X Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr;
X ActiveVarTrace *activePtr;
X
X /*
X * First, lookup the variable.
X */
X

X return;

X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X if (varPtr->flags & VAR_UPVAR) {
X hPtr = varPtr->value.upvarPtr;
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X }
X if (name2 != NULL) {
X if (!(varPtr->flags & VAR_ARRAY)) {

X return;

X }
X hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X if (hPtr == NULL) {

X return;

X }
X varPtr = (Var *) Tcl_GetHashValue(hPtr);
X }
X

X flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
X for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
X prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
X if (tracePtr == NULL) {
X return;
X }
X if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
X && (tracePtr->clientData == clientData)) {

X break;
X }
X }
X

X /*
X * The code below makes it possible to delete traces while traces
X * are active: it makes sure that the deleted trace won't be
X * processed by CallTraces.
X */
X
X for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
X activePtr = activePtr->nextPtr) {
X if (activePtr->nextTracePtr == tracePtr) {
X activePtr->nextTracePtr = tracePtr->nextPtr;
X }

X }
X if (prevPtr == NULL) {

X varPtr->tracePtr = tracePtr->nextPtr;

X } else {
X prevPtr->nextPtr = tracePtr->nextPtr;
X }

X ckfree((char *) tracePtr);
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_VarTraceInfo --
X *
X * Return the clientData value associated with a trace on a
X * variable. This procedure can also be used to step through
X * all of the traces on a particular variable that have the
X * same trace procedure.
X *
X * Results:
X * The return value is the clientData value associated with
X * a trace on the given variable. Information will only be
X * returned for a trace with proc as trace procedure. If
X * the clientData argument is NULL then the first such trace is
X * returned; otherwise, the next relevant one after the one
X * given by clientData will be returned. If the variable
X * doesn't exist, or if there are no (more) traces for it,
X * then NULL is returned.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

XClientData
XTcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)

X Tcl_Interp *interp; /* Interpreter containing variable. */

X char *varName; /* Name of variable; may end with "(index)"
X * to signify an array reference. */

X int flags; /* 0 or TCL_GLOBAL_ONLY. */
X Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
X ClientData prevClientData; /* If non-NULL, gives last value returned
X * by this procedure, so this call will
X * return the next trace after that one.
X * If NULL, this call will return the

X * first trace. */
X{
X register char *p;
X
X /*
X * If varName refers to an array (it ends with a parenthesized
X * element name), then handle it specially.
X */
X
X for (p = varName; *p != '\0'; p++) {
X if (*p == '(') {
X ClientData result;
X char *open = p;
X
X do {
X p++;
X } while (*p != '\0');
X p--;
X if (*p != ')') {
X goto scalar;
X }
X *open = '\0';
X *p = '\0';
X result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
X prevClientData);
X *open = '(';
X *p = ')';

X return result;
X }
X }
X

X scalar:
X return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
X prevClientData);
X}
END_OF_FILE
if test 32992 -ne `wc -c <'tcl6.1/tclVar.c.1'`; then
echo shar: \"'tcl6.1/tclVar.c.1'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclVar.c.1'
fi
echo shar: End of archive 25 $of 33$.
cp /dev/null ark25isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:55:35 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 94
Archive-name: tcl/part26
Environment: UNIX

# "End of archive 26 (of 33)."
# Contents: tcl6.1/tclExpr.c
# Wrapped by karl@one on Tue Nov 12 19:44:30 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclExpr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclExpr.c'\"
else
echo shar: Extracting \"'tcl6.1/tclExpr.c'\" $34117 characters$
sed "s/^X//" >'tcl6.1/tclExpr.c' <<'END_OF_FILE'
X/*
X * tclExpr.c --
X *
X * This file contains the code to evaluate expressions for
X * Tcl.
X *
X * This implementation of floating-point support was modelled
X * after an initial implementation by Bill Carpenter.
X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclExpr.c,v 1.32 91/10/31 14:04:03 ouster Exp $ SPRITE (Berkeley)";

X#endif
X
X#include "tclInt.h"
X

Xdouble strtod();
X
X/*
X * The stuff below is a bit of a hack so that this file can be used
X * in environments that include no UNIX, i.e. no errno. Just define
X * errno here.
X */
X
X#ifndef TCL_NO_UNIX
X#include "tclUnix.h"
X#else
Xint errno;
X#define ERANGE 34
X#endif
X
X/*
X * The data structure below is used to describe an expression value,
X * which can be either an integer (the usual case), a double-precision
X * floating-point value, or a string. A given number has only one
X * value at a time.
X */
X
X#define STATIC_STRING_SPACE 150
X
Xtypedef struct {
X long intValue; /* Integer value, if any. */
X double doubleValue; /* Floating-point value, if any. */
X ParseValue pv; /* Used to hold a string value, if any. */
X char staticSpace[STATIC_STRING_SPACE];
X /* Storage for small strings; large ones
X * are malloc-ed. */
X int type; /* Type of value: TYPE_INT, TYPE_DOUBLE,
X * or TYPE_STRING. */
X} Value;
X
X/*
X * Valid values for type:
X */
X
X#define TYPE_INT 0
X#define TYPE_DOUBLE 1
X#define TYPE_STRING 2
X
X
X/*
X * The data structure below describes the state of parsing an expression.
X * It's passed among the routines in this module.
X */
X
Xtypedef struct {
X char *originalExpr; /* The entire expression, as originally
X * passed to Tcl_Expr. */
X char *expr; /* Position to the next character to be
X * scanned from the expression string. */
X int token; /* Type of the last token to be parsed from
X * expr. See below for definitions.
X * Corresponds to the characters just
X * before expr. */
X} ExprInfo;
X
X/*
X * The token types are defined below. In addition, there is a table
X * associating a precedence with each operator. The order of types
X * is important. Consult the code before changing it.
X */
X
X#define VALUE 0
X#define OPEN_PAREN 1
X#define CLOSE_PAREN 2
X#define END 3
X#define UNKNOWN 4
X
X/*
X * Binary operators:
X */
X
X#define MULT 8
X#define DIVIDE 9
X#define MOD 10
X#define PLUS 11
X#define MINUS 12
X#define LEFT_SHIFT 13
X#define RIGHT_SHIFT 14
X#define LESS 15
X#define GREATER 16
X#define LEQ 17
X#define GEQ 18
X#define EQUAL 19
X#define NEQ 20
X#define BIT_AND 21
X#define BIT_XOR 22
X#define BIT_OR 23
X#define AND 24
X#define OR 25
X#define QUESTY 26
X#define COLON 27
X
X/*
X * Unary operators:
X */
X
X#define UNARY_MINUS 28
X#define NOT 29
X#define BIT_NOT 30
X
X/*
X * Precedence table. The values for non-operator token types are ignored.
X */
X
Xint precTable[] = {
X 0, 0, 0, 0, 0, 0, 0, 0,
X 11, 11, 11, /* MULT, DIVIDE, MOD */
X 10, 10, /* PLUS, MINUS */
X 9, 9, /* LEFT_SHIFT, RIGHT_SHIFT */
X 8, 8, 8, 8, /* LESS, GREATER, LEQ, GEQ */
X 7, 7, /* EQUAL, NEQ */
X 6, /* BIT_AND */
X 5, /* BIT_XOR */
X 4, /* BIT_OR */
X 3, /* AND */
X 2, /* OR */
X 1, 1, /* QUESTY, COLON */
X 12, 12, 12 /* UNARY_MINUS, NOT, BIT_NOT */
X};
X
X/*
X * Mapping from operator numbers to strings; used for error messages.
X */
X
Xchar *operatorStrings[] = {
X "VALUE", "(", ")", "END", "UNKNOWN", "5", "6", "7",
X "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
X ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
X "-", "!", "~"
X};
X
X/*
X * Declarations for local procedures to this file:
X */
X
Xstatic int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
X ExprInfo *infoPtr, int prec, Value *valuePtr));
Xstatic int ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
X ExprInfo *infoPtr, Value *valuePtr));
Xstatic void ExprMakeString _ANSI_ARGS_((Value *valuePtr));
Xstatic int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, Value *valuePtr));
Xstatic int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
X char *string, Value *valuePtr));

X
X/*
X *--------------------------------------------------------------
X *

X * ExprParseString --
X *
X * Given a string (such as one coming from command or variable
X * substitution), make a Value based on the string. The value
X * will be a floating-point or integer, if possible, or else it
X * will just be a copy of the string.

X *
X * Results:

X * TCL_OK is returned under normal circumstances, and TCL_ERROR
X * is returned if a floating-point overflow or underflow occurred
X * while reading in a number. The value at *valuePtr is modified
X * to hold a number, if possible.
X *

X * Side effects:
X * None.
X *
X *--------------------------------------------------------------

X */
X
Xstatic int

XExprParseString(interp, string, valuePtr)
X Tcl_Interp *interp; /* Where to store error message. */
X char *string; /* String to turn into value. */
X Value *valuePtr; /* Where to store value information.
X * Caller must have initialized pv field. */
X{
X register char c;
X
X /*
X * Try to convert the string to a number.
X */
X
X c = *string;
X if (((c >= '0') && (c <= '9')) || (c == '-')) {
X char *term;
X
X valuePtr->type = TYPE_INT;
X errno = 0;
X valuePtr->intValue = strtol(string, &term, 0);
X c = *term;
X if ((c == '\0') && (errno != ERANGE)) {
X return TCL_OK;
X }
X if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
X errno = 0;
X valuePtr->doubleValue = strtod(string, &term);
X if (errno == ERANGE) {
X Tcl_ResetResult(interp);
X if (valuePtr->doubleValue == 0.0) {
X Tcl_AppendResult(interp, "floating-point value \"",
X string, "\" too small to represent",
X (char *) NULL);
X } else {
X Tcl_AppendResult(interp, "floating-point value \"",
X string, "\" too large to represent",

X (char *) NULL);
X }

X return TCL_ERROR;
X }
X if (*term == '\0') {
X valuePtr->type = TYPE_DOUBLE;

X return TCL_OK;
X }
X }

X }
X
X /*
X * Not a valid number. Save a string value (but don't do anything
X * if it's already the value).
X */
X
X valuePtr->type = TYPE_STRING;
X if (string != valuePtr->pv.buffer) {
X int length, shortfall;

X
X length = strlen(string);

X valuePtr->pv.next = valuePtr->pv.buffer;
X shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
X if (shortfall > 0) {
X (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
X }
X strcpy(valuePtr->pv.buffer, string);

X }
X return TCL_OK;
X}

X
X/*
X *----------------------------------------------------------------------
X *

X * ExprLex --
X *
X * Lexical analyzer for expression parser: parses a single value,
X * operator, or other syntactic element from an expression string.

X *
X * Results:

X * TCL_OK is returned unless an error occurred while doing lexical
X * analysis or executing an embedded command. In that case a
X * standard Tcl error is returned, using interp->result to hold
X * an error message. In the event of a successful return, the token
X * and field in infoPtr is updated to refer to the next symbol in
X * the expression string, and the expr field is advanced past that
X * token; if the token is a value, then the value is stored at
X * valuePtr.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XExprLex(interp, infoPtr, valuePtr)

X Tcl_Interp *interp; /* Interpreter to use for error

X * reporting. */
X register ExprInfo *infoPtr; /* Describes the state of the parse. */
X register Value *valuePtr; /* Where to store value, if that is
X * what's parsed from string. Caller
X * must have initialized pv field
X * correctly. */
X{
X register char *p, c;
X char *var, *term;
X int result;
X
X p = infoPtr->expr;
X c = *p;
X while (isspace(c)) {
X p++;

X c = *p;
X }

X infoPtr->expr = p+1;
X switch (c) {
X case '0':
X case '1':
X case '2':
X case '3':
X case '4':
X case '5':
X case '6':
X case '7':
X case '8':
X case '9':
X case '.':
X
X /*
X * Number. First read an integer. Then if it looks like
X * there's a floating-point number (or if it's too big a
X * number to fit in an integer), parse it as a floating-point
X * number.
X */
X
X infoPtr->token = VALUE;
X valuePtr->type = TYPE_INT;
X errno = 0;
X valuePtr->intValue = strtoul(p, &term, 0);
X c = *term;
X if ((c == '.') || (c == 'e') || (c == 'E') || (errno == ERANGE)) {
X char *term2;
X
X errno = 0;
X valuePtr->doubleValue = strtod(p, &term2);
X if (errno == ERANGE) {
X Tcl_ResetResult(interp);
X if (valuePtr->doubleValue == 0.0) {
X interp->result =
X "floating-point value too small to represent";
X } else {
X interp->result =
X "floating-point value too large to represent";
X }
X return TCL_ERROR;
X }
X if (term2 == infoPtr->expr) {
X interp->result = "poorly-formed floating-point value";
X return TCL_ERROR;
X }
X valuePtr->type = TYPE_DOUBLE;
X infoPtr->expr = term2;
X } else {
X infoPtr->expr = term;
X }
X return TCL_OK;
X
X case '$':
X
X /*
X * Variable. Fetch its value, then see if it makes sense
X * as an integer or floating-point number.
X */
X
X infoPtr->token = VALUE;
X var = Tcl_ParseVar(interp, p, &infoPtr->expr);
X if (var == NULL) {
X return TCL_ERROR;
X }
X if (((Interp *) interp)->noEval) {
X valuePtr->type = TYPE_INT;
X valuePtr->intValue = 0;
X return TCL_OK;
X }
X return ExprParseString(interp, var, valuePtr);
X
X case '[':
X infoPtr->token = VALUE;
X result = Tcl_Eval(interp, p+1, TCL_BRACKET_TERM,
X &infoPtr->expr);

X if (result != TCL_OK) {

X return result;
X }
X infoPtr->expr++;
X if (((Interp *) interp)->noEval) {
X valuePtr->type = TYPE_INT;
X valuePtr->intValue = 0;
X Tcl_ResetResult(interp);
X return TCL_OK;
X }
X result = ExprParseString(interp, interp->result, valuePtr);

X if (result != TCL_OK) {

X return result;
X }
X Tcl_ResetResult(interp);
X return TCL_OK;
X
X case '"':
X infoPtr->token = VALUE;
X result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
X &infoPtr->expr, &valuePtr->pv);

X if (result != TCL_OK) {

X return result;
X }
X return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
X
X case '{':
X infoPtr->token = VALUE;
X result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
X &valuePtr->pv);

X if (result != TCL_OK) {

X return result;
X }
X return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
X
X case '(':
X infoPtr->token = OPEN_PAREN;
X return TCL_OK;
X
X case ')':
X infoPtr->token = CLOSE_PAREN;
X return TCL_OK;
X
X case '*':
X infoPtr->token = MULT;
X return TCL_OK;
X
X case '/':
X infoPtr->token = DIVIDE;
X return TCL_OK;
X
X case '%':
X infoPtr->token = MOD;
X return TCL_OK;
X
X case '+':
X infoPtr->token = PLUS;
X return TCL_OK;
X
X case '-':
X infoPtr->token = MINUS;
X return TCL_OK;
X
X case '?':
X infoPtr->token = QUESTY;
X return TCL_OK;
X
X case ':':
X infoPtr->token = COLON;
X return TCL_OK;
X
X case '<':
X switch (p[1]) {
X case '<':
X infoPtr->expr = p+2;
X infoPtr->token = LEFT_SHIFT;
X break;
X case '=':
X infoPtr->expr = p+2;
X infoPtr->token = LEQ;
X break;
X default:
X infoPtr->token = LESS;
X break;
X }
X return TCL_OK;
X
X case '>':
X switch (p[1]) {
X case '>':
X infoPtr->expr = p+2;
X infoPtr->token = RIGHT_SHIFT;
X break;
X case '=':
X infoPtr->expr = p+2;
X infoPtr->token = GEQ;
X break;
X default:
X infoPtr->token = GREATER;
X break;
X }
X return TCL_OK;
X
X case '=':
X if (p[1] == '=') {
X infoPtr->expr = p+2;
X infoPtr->token = EQUAL;
X } else {
X infoPtr->token = UNKNOWN;
X }
X return TCL_OK;
X
X case '!':
X if (p[1] == '=') {
X infoPtr->expr = p+2;
X infoPtr->token = NEQ;
X } else {
X infoPtr->token = NOT;
X }
X return TCL_OK;
X
X case '&':
X if (p[1] == '&') {
X infoPtr->expr = p+2;
X infoPtr->token = AND;
X } else {
X infoPtr->token = BIT_AND;
X }
X return TCL_OK;
X
X case '^':
X infoPtr->token = BIT_XOR;
X return TCL_OK;
X
X case '|':
X if (p[1] == '|') {
X infoPtr->expr = p+2;
X infoPtr->token = OR;
X } else {
X infoPtr->token = BIT_OR;
X }
X return TCL_OK;
X
X case '~':
X infoPtr->token = BIT_NOT;
X return TCL_OK;
X
X case 0:
X infoPtr->token = END;
X infoPtr->expr = p;
X return TCL_OK;
X
X default:
X infoPtr->expr = p+1;
X infoPtr->token = UNKNOWN;
X return TCL_OK;
X }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ExprGetValue --
X *
X * Parse a "value" from the remainder of the expression in infoPtr.

X *
X * Results:

X * Normally TCL_OK is returned. The value of the expression is
X * returned in *valuePtr. If an error occurred, then interp->result
X * contains an error message and TCL_ERROR is returned.
X * InfoPtr->token will be left pointing to the token AFTER the
X * expression, and infoPtr->expr will point to the character just
X * after the terminating token.

X *
X * Side effects:
X * None.
X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XExprGetValue(interp, infoPtr, prec, valuePtr)

X Tcl_Interp *interp; /* Interpreter to use for error

X * reporting. */
X register ExprInfo *infoPtr; /* Describes the state of the parse
X * just before the value (i.e. ExprLex
X * will be called to get first token
X * of value). */
X int prec; /* Treat any un-parenthesized operator
X * with precedence <= this as the end
X * of the expression. */
X Value *valuePtr; /* Where to store the value of the
X * expression. Caller must have
X * initialized pv field. */
X{

X Interp *iPtr = (Interp *) interp;

X Value value2; /* Second operand for current
X * operator. */
X int operator; /* Current operator (either unary
X * or binary). */
X int badType; /* Type of offending argument; used
X * for error messages. */
X int gotOp; /* Non-zero means already lexed the
X * operator (while picking up value
X * for unary operator). Don't lex
X * again. */

X int result;
X
X /*

X * There are two phases to this procedure. First, pick off an initial
X * value. Then, parse (binary operator, value) pairs until done.
X */
X
X gotOp = 0;
X value2.pv.buffer = value2.pv.next = value2.staticSpace;
X value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
X value2.pv.expandProc = TclExpandParseValue;
X value2.pv.clientData = (ClientData) NULL;
X result = ExprLex(interp, infoPtr, valuePtr);

X if (result != TCL_OK) {

X goto done;
X }
X if (infoPtr->token == OPEN_PAREN) {
X
X /*
X * Parenthesized sub-expression.
X */
X
X result = ExprGetValue(interp, infoPtr, -1, valuePtr);

X if (result != TCL_OK) {

X goto done;
X }
X if (infoPtr->token != CLOSE_PAREN) {

X Tcl_ResetResult(interp);
X sprintf(interp->result,

X "unmatched parentheses in expression \"%.50s\"",
X infoPtr->originalExpr);
X result = TCL_ERROR;
X goto done;
X }
X } else {
X if (infoPtr->token == MINUS) {
X infoPtr->token = UNARY_MINUS;
X }
X if (infoPtr->token >= UNARY_MINUS) {
X
X /*
X * Process unary operators.
X */
X
X operator = infoPtr->token;
X result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
X valuePtr);

X if (result != TCL_OK) {

X goto done;
X }
X switch (operator) {
X case UNARY_MINUS:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue = -valuePtr->intValue;
X } else if (valuePtr->type == TYPE_DOUBLE){
X valuePtr->doubleValue = -valuePtr->doubleValue;
X } else {
X badType = valuePtr->type;
X goto illegalType;
X }
X break;
X case NOT:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue = !valuePtr->intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue = !valuePtr->doubleValue;
X valuePtr->type = TYPE_INT;
X } else {
X badType = valuePtr->type;
X goto illegalType;
X }
X break;
X case BIT_NOT:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue = ~valuePtr->intValue;
X } else {
X badType = valuePtr->type;
X goto illegalType;
X }
X break;
X }
X gotOp = 1;
X } else if (infoPtr->token != VALUE) {
X goto syntaxError;

X }
X }
X
X /*

X * Got the first operand. Now fetch (operator, operand) pairs.
X */
X
X if (!gotOp) {
X result = ExprLex(interp, infoPtr, &value2);

X if (result != TCL_OK) {

X goto done;
X }
X }

X while (1) {
X operator = infoPtr->token;
X value2.pv.next = value2.pv.buffer;
X if ((operator < MULT) || (operator >= UNARY_MINUS)) {
X if ((operator == END) || (operator == CLOSE_PAREN)) {
X result = TCL_OK;
X goto done;
X } else {
X goto syntaxError;
X }
X }
X if (precTable[operator] <= prec) {
X result = TCL_OK;
X goto done;
X }
X
X /*
X * If we're doing an AND or OR and the first operand already
X * determines the result, don't execute anything in the
X * second operand: just parse. Same style for ?: pairs.
X */
X
X if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
X if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue = valuePtr->doubleValue != 0;
X valuePtr->type = TYPE_INT;
X } else if (valuePtr->type == TYPE_STRING) {
X badType = TYPE_STRING;
X goto illegalType;
X }
X if (((operator == AND) && !valuePtr->intValue)
X || ((operator == OR) && valuePtr->intValue)) {
X iPtr->noEval++;
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X &value2);
X iPtr->noEval--;
X } else if (operator == QUESTY) {
X if (valuePtr->intValue != 0) {
X valuePtr->pv.next = valuePtr->pv.buffer;
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X valuePtr);

X if (result != TCL_OK) {

X goto done;
X }
X if (infoPtr->token != COLON) {
X goto syntaxError;
X }
X value2.pv.next = value2.pv.buffer;
X iPtr->noEval++;
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X &value2);
X iPtr->noEval--;
X } else {
X iPtr->noEval++;
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X &value2);
X iPtr->noEval--;

X if (result != TCL_OK) {

X goto done;
X }
X if (infoPtr->token != COLON) {
X goto syntaxError;
X }
X valuePtr->pv.next = valuePtr->pv.buffer;
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X valuePtr);
X }
X } else {
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X &value2);
X }
X } else {
X result = ExprGetValue(interp, infoPtr, precTable[operator],
X &value2);

X }
X if (result != TCL_OK) {

X goto done;
X }
X if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
X && (infoPtr->token != END)
X && (infoPtr->token != CLOSE_PAREN)) {
X goto syntaxError;
X }
X
X /*
X * At this point we've got two values and an operator. Check
X * to make sure that the particular data types are appropriate
X * for the particular operator, and perform type conversion
X * if necessary.
X */
X
X switch (operator) {
X
X /*
X * For the operators below, no strings are allowed and
X * ints get converted to floats if necessary.
X */
X
X case MULT: case DIVIDE: case PLUS: case MINUS:
X if ((valuePtr->type == TYPE_STRING)
X || (value2.type == TYPE_STRING)) {
X badType = TYPE_STRING;
X goto illegalType;
X }
X if (valuePtr->type == TYPE_DOUBLE) {
X if (value2.type == TYPE_INT) {
X value2.doubleValue = value2.intValue;
X value2.type = TYPE_DOUBLE;
X }
X } else if (value2.type == TYPE_DOUBLE) {
X if (valuePtr->type == TYPE_INT) {
X valuePtr->doubleValue = valuePtr->intValue;
X valuePtr->type = TYPE_DOUBLE;
X }
X }
X break;
X
X /*
X * For the operators below, only integers are allowed.
X */
X
X case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
X case BIT_AND: case BIT_XOR: case BIT_OR:
X if (valuePtr->type != TYPE_INT) {
X badType = valuePtr->type;
X goto illegalType;
X } else if (value2.type != TYPE_INT) {
X badType = value2.type;
X goto illegalType;
X }
X break;
X
X /*
X * For the operators below, any type is allowed but the
X * two operands must have the same type. Convert integers
X * to floats and either to strings, if necessary.
X */
X
X case LESS: case GREATER: case LEQ: case GEQ:
X case EQUAL: case NEQ:
X if (valuePtr->type == TYPE_STRING) {
X if (value2.type != TYPE_STRING) {
X ExprMakeString(&value2);
X }
X } else if (value2.type == TYPE_STRING) {
X if (valuePtr->type != TYPE_STRING) {
X ExprMakeString(valuePtr);
X }
X } else if (valuePtr->type == TYPE_DOUBLE) {
X if (value2.type == TYPE_INT) {
X value2.doubleValue = value2.intValue;
X value2.type = TYPE_DOUBLE;
X }
X } else if (value2.type == TYPE_DOUBLE) {
X if (valuePtr->type == TYPE_INT) {
X valuePtr->doubleValue = valuePtr->intValue;
X valuePtr->type = TYPE_DOUBLE;
X }
X }
X break;
X
X /*
X * For the operators below, no strings are allowed, but
X * no int->double conversions are performed.
X */
X
X case AND: case OR:
X if (valuePtr->type == TYPE_STRING) {
X badType = valuePtr->type;
X goto illegalType;
X }
X if (value2.type == TYPE_STRING) {
X badType = value2.type;
X goto illegalType;
X }
X break;
X
X /*
X * For the operators below, type and conversions are
X * irrelevant: they're handled elsewhere.
X */
X
X case QUESTY: case COLON:
X break;
X
X /*
X * Any other operator is an error.
X */
X
X default:
X interp->result = "unknown operator in expression";

X result = TCL_ERROR;
X goto done;

X }
X
X /*
X * If necessary, convert one of the operands to the type
X * of the other. If the operands are incompatible with
X * the operator (e.g. "+" on strings) then return an
X * error.
X */
X
X switch (operator) {
X case MULT:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue *= value2.intValue;
X } else {
X valuePtr->doubleValue *= value2.doubleValue;
X }
X break;
X case DIVIDE:
X if (valuePtr->type == TYPE_INT) {
X if (value2.intValue == 0) {
X divideByZero:
X interp->result = "divide by zero";
X result = TCL_ERROR;
X goto done;
X }
X valuePtr->intValue /= value2.intValue;
X } else {
X if (value2.doubleValue == 0.0) {
X goto divideByZero;
X }
X valuePtr->doubleValue /= value2.doubleValue;
X }
X break;
X case MOD:
X if (value2.intValue == 0) {
X goto divideByZero;
X }
X valuePtr->intValue %= value2.intValue;

X break;
X case PLUS:

X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue += value2.intValue;
X } else {
X valuePtr->doubleValue += value2.doubleValue;
X }
X break;
X case MINUS:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue -= value2.intValue;
X } else {
X valuePtr->doubleValue -= value2.doubleValue;
X }
X break;
X case LEFT_SHIFT:
X valuePtr->intValue <<= value2.intValue;
X break;
X case RIGHT_SHIFT:
X /*
X * The following code is a bit tricky: it ensures that
X * right shifts propagate the sign bit even on machines
X * where ">>" won't do it by default.
X */
X
X if (valuePtr->intValue < 0) {
X valuePtr->intValue =
X ~((~valuePtr->intValue) >> value2.intValue);
X } else {
X valuePtr->intValue >>= value2.intValue;
X }
X break;
X case LESS:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue < value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue < value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case GREATER:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue > value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue > value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case LEQ:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue <= value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue <= value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case GEQ:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue >= value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue >= value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case EQUAL:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue == value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue == value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case NEQ:
X if (valuePtr->type == TYPE_INT) {
X valuePtr->intValue =
X valuePtr->intValue != value2.intValue;
X } else if (valuePtr->type == TYPE_DOUBLE) {
X valuePtr->intValue =
X valuePtr->doubleValue != value2.doubleValue;
X } else {
X valuePtr->intValue =
X strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
X }
X valuePtr->type = TYPE_INT;
X break;
X case BIT_AND:
X valuePtr->intValue &= value2.intValue;
X break;
X case BIT_XOR:
X valuePtr->intValue ^= value2.intValue;
X break;
X case BIT_OR:
X valuePtr->intValue |= value2.intValue;
X break;
X
X /*
X * For AND and OR, we know that the first value has already
X * been converted to an integer. Thus we need only consider
X * the possibility of int vs. double for the second value.
X */
X
X case AND:
X if (value2.type == TYPE_DOUBLE) {
X value2.intValue = value2.doubleValue != 0;
X value2.type = TYPE_INT;
X }
X valuePtr->intValue = valuePtr->intValue && value2.intValue;
X break;
X case OR:
X if (value2.type == TYPE_DOUBLE) {
X value2.intValue = value2.doubleValue != 0;
X value2.type = TYPE_INT;
X }
X valuePtr->intValue = valuePtr->intValue || value2.intValue;
X break;
X
X case COLON:
X interp->result = "can't have : operator without ? first";
X result = TCL_ERROR;

X goto done;
X }
X }
X

X done:
X if (value2.pv.buffer != value2.staticSpace) {
X ckfree(value2.pv.buffer);
X }
X return result;
X
X syntaxError:
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "syntax error in expression \"",
X infoPtr->originalExpr, "\"", (char *) NULL);
X result = TCL_ERROR;
X goto done;
X
X illegalType:
X Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
X "floating-point value" : "non-numeric string",
X " as operand of \"", operatorStrings[operator], "\"",
X (char *) NULL);
X result = TCL_ERROR;

X goto done;
X}
X

X/*
X *--------------------------------------------------------------
X *

X * ExprMakeString --
X *
X * Convert a value from int or double representation to
X * a string.

X *
X * Results:

X * The information at *valuePtr gets converted to string
X * format, if it wasn't that way already.

X *
X * Side effects:
X * None.
X *
X *--------------------------------------------------------------

X */
X
Xstatic void

XExprMakeString(valuePtr)
X register Value *valuePtr; /* Value to be converted. */
X{
X int shortfall;
X
X shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
X if (shortfall > 0) {
X (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
X }
X if (valuePtr->type == TYPE_INT) {
X sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
X } else if (valuePtr->type == TYPE_DOUBLE) {
X sprintf(valuePtr->pv.buffer, "%g", valuePtr->doubleValue);
X }
X valuePtr->type = TYPE_STRING;

X}
X
X/*
X *--------------------------------------------------------------
X *

X * ExprTopLevel --
X *
X * This procedure provides top-level functionality shared by
X * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.

X *
X * Results:

X * The result is a standard Tcl return value. If an error
X * occurs then an error message is left in interp->result.
X * The value of the expression is returned in *valuePtr, in
X * whatever form it ends up in (could be string or integer
X * or double). Caller may need to convert result. Caller
X * is also responsible for freeing string memory in *valuePtr,
X * if any was allocated.

X *
X * Side effects:
X * None.
X *
X *--------------------------------------------------------------

X */
X
Xstatic int

XExprTopLevel(interp, string, valuePtr)
X Tcl_Interp *interp; /* Context in which to evaluate the
X * expression. */
X char *string; /* Expression to evaluate. */
X Value *valuePtr; /* Where to store result. Should
X * not be initialized by caller. */
X{
X ExprInfo info;
X int result;
X
X info.originalExpr = string;
X info.expr = string;
X valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
X valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
X valuePtr->pv.expandProc = TclExpandParseValue;
X valuePtr->pv.clientData = (ClientData) NULL;
X
X result = ExprGetValue(interp, &info, -1, valuePtr);

X if (result != TCL_OK) {

X return result;
X }
X if (info.token != END) {
X Tcl_AppendResult(interp, "syntax error in expression \"",

X string, "\"", (char *) NULL);

X return TCL_ERROR;
X }

X return TCL_OK;
X}
X
X/*

X *--------------------------------------------------------------
X *
X * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
X *
X * Procedures to evaluate an expression and return its value
X * in a particular form.

X *
X * Results:

X * Each of the procedures below returns a standard Tcl result.
X * If an error occurs then an error message is left in
X * interp->result. Otherwise the value of the expression,
X * in the appropriate form, is stored at *resultPtr. If
X * the expression had a result that was incompatible with the
X * desired form then an error is returned.

X *
X * Side effects:
X * None.
X *

X *--------------------------------------------------------------
X */
X
Xint

XTcl_ExprLong(interp, string, ptr)
X Tcl_Interp *interp; /* Context in which to evaluate the
X * expression. */
X char *string; /* Expression to evaluate. */
X long *ptr; /* Where to store result. */
X{
X Value value;
X int result;
X
X result = ExprTopLevel(interp, string, &value);

X if (result == TCL_OK) {

X if (value.type == TYPE_INT) {
X *ptr = value.intValue;
X } else if (value.type == TYPE_DOUBLE) {
X *ptr = value.doubleValue;
X } else {
X interp->result = "expression didn't have numeric value";
X result = TCL_ERROR;
X }
X }
X if (value.pv.buffer != value.staticSpace) {
X ckfree(value.pv.buffer);
X }

X return result;
X}
X

Xint
XTcl_ExprDouble(interp, string, ptr)
X Tcl_Interp *interp; /* Context in which to evaluate the
X * expression. */
X char *string; /* Expression to evaluate. */
X double *ptr; /* Where to store result. */
X{
X Value value;
X int result;
X
X result = ExprTopLevel(interp, string, &value);

X if (result == TCL_OK) {

X return result;
X}
X

Xint
XTcl_ExprBoolean(interp, string, ptr)
X Tcl_Interp *interp; /* Context in which to evaluate the
X * expression. */
X char *string; /* Expression to evaluate. */
X int *ptr; /* Where to store 0/1 result. */
X{
X Value value;
X int result;
X
X result = ExprTopLevel(interp, string, &value);

X if (result == TCL_OK) {

X if (value.type == TYPE_INT) {
X *ptr = value.intValue != 0;
X } else if (value.type == TYPE_DOUBLE) {
X *ptr = value.doubleValue != 0.0;
X } else {
X interp->result = "expression didn't have numeric value";
X result = TCL_ERROR;
X }
X }
X if (value.pv.buffer != value.staticSpace) {
X ckfree(value.pv.buffer);
X }

X return result;
X}
X

X/*
X *--------------------------------------------------------------
X *

X * Tcl_ExprString --
X *
X * Evaluate an expression and return its value in string form.

X *
X * Results:

X * A standard Tcl result. If the result is TCL_OK, then the
X * interpreter's result is set to the string value of the
X * expression. If the result is TCL_OK, then interp->result
X * contains an error message.

X *
X * Side effects:
X * None.
X *

X *--------------------------------------------------------------
X */
X
Xint

XTcl_ExprString(interp, string)
X Tcl_Interp *interp; /* Context in which to evaluate the
X * expression. */
X char *string; /* Expression to evaluate. */
X{
X Value value;
X int result;
X
X result = ExprTopLevel(interp, string, &value);

X if (result == TCL_OK) {

X if (value.type == TYPE_INT) {
X sprintf(interp->result, "%ld", value.intValue);
X } else if (value.type == TYPE_DOUBLE) {
X sprintf(interp->result, "%g", value.doubleValue);
X } else {
X if (value.pv.buffer != value.staticSpace) {
X interp->result = value.pv.buffer;
X interp->freeProc = (Tcl_FreeProc *) free;
X value.pv.buffer = value.staticSpace;
X } else {
X Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
X }
X }
X }
X if (value.pv.buffer != value.staticSpace) {
X ckfree(value.pv.buffer);

X }
X return result;
X}
END_OF_FILE

if test 34117 -ne `wc -c <'tcl6.1/tclExpr.c'`; then
echo shar: \"'tcl6.1/tclExpr.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclExpr.c'
fi
echo shar: End of archive 26 $of 33$.
cp /dev/null ark26isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:55:55 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 95
Archive-name: tcl/part27
Environment: UNIX

# "End of archive 27 (of 33)."
# Contents: tcl6.1/doc/Tcl.man.1

# Wrapped by karl@one on Tue Nov 12 19:44:30 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/Tcl.man.1' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Tcl.man.1'\"
else
echo shar: Extracting \"'tcl6.1/doc/Tcl.man.1'\" $35297 characters$
sed "s/^X//" >'tcl6.1/doc/Tcl.man.1' <<'END_OF_FILE'

X'\" provided "as is" without express or implied warranty.
X'\"
X'\" $Header: /user6/ouster/tcl/doc/RCS/Tcl.man,v 1.86 91/10/31 13:35:32 ouster Exp $ SPRITE (Berkeley)

X.br
X.mk ^y

X.de UL
X\\$1\l'|0\(ul'\\$2
X..

X.HS Tcl tcl
X.BS
X.SH NAME
XTcl \- overview of tool command language facilities

X.BE
X
X.SH INTRODUCTION
X.PP

XTcl stands for ``tool command language'' and is pronounced ``tickle.''
XIt is actually two things:
Xa language and a library.
XFirst, Tcl is a simple textual language,
Xintended primarily for issuing commands to interactive programs such
Xas text editors, debuggers, illustrators, and shells. It has
Xa simple syntax and is also programmable, so
XTcl users can write command procedures to provide more powerful
Xcommands than those in the built-in set.
X.PP
XSecond, Tcl is a library package that can be embedded in application
Xprograms. The Tcl library consists of a parser for the Tcl
Xlanguage, routines to implement the Tcl built-in commands, and
Xprocedures that allow each application to extend Tcl with additional
Xcommands specific to that application. The application program
Xgenerates Tcl commands and passes them to the Tcl parser for
Xexecution. Commands may be generated
Xby reading characters from an input
Xsource, or by associating command strings with elements of the
Xapplication's user interface, such as menu entries, buttons, or
Xkeystrokes.
XWhen the Tcl library receives commands it parses them
Xinto component fields and executes built-in commands directly.
XFor commands implemented by the
Xapplication, Tcl calls back to the application to execute the
Xcommands. In many cases commands will invoke recursive invocations
Xof the Tcl interpreter by passing in additional strings to execute
X(procedures, looping commands, and conditional commands all work
Xin this way).
X.PP
XAn application program gains three advantages by using Tcl for
Xits command language. First, Tcl provides a standard syntax: once
Xusers know Tcl, they will be able to issue commands easily
Xto any Tcl-based application. Second, Tcl provides programmability.
XAll a Tcl application needs to do is to implement a few
Xapplication-specific low-level commands. Tcl provides many utility
Xcommands plus a general programming interface for building up
Xcomplex command procedures. By using Tcl, applications need not
Xre-implement these features. Third, Tcl can be used as
X.VS
Xa common language for communicating between applications.
XInter-application communication is not built into the Tcl core
Xdescribed here, but various add-on libraries, such as the Tk toolkit,
Xallow applications to issue commands to each other.
XThis makes it possible for applications to work together in much
Xmore powerful ways than was previously possible.
X.VE
X.PP
XThis manual page focuses primarily on the Tcl language. It describes
Xthe language syntax and the built-in commands that will be available in
Xany application based on Tcl. The individual library
Xprocedures are described in more detail in separate manual pages, one
Xper procedure.
X
X.SH "INTERPRETERS"
X.PP
XThe central data structure in Tcl is an interpreter (C type
X``Tcl_Interp''). An interpreter consists of a set of command
Xbindings, a set of variable values, and a few other miscellaneous
Xpieces of state. Each Tcl command is interpreted in the context
Xof a particular interpreter.
XSome Tcl-based applications will maintain
Xmultiple interpreters simultaneously, each associated with a
Xdifferent widget or portion of the application.
XInterpreters are relatively lightweight structures. They can
Xbe created and deleted quickly, so application programmers should feel free to
Xuse multiple interpreters if that simplifies the application.
XEventually Tcl will provide a mechanism for sending Tcl commands
Xand results back and forth between interpreters, even if the
Xinterpreters are managed by different processes.
X
X.SH "DATA TYPES"
X.PP
XTcl supports only one type of data: strings. All commands,
Xall arguments to commands, all command results, and all variable values
Xare strings.
XWhere commands require numeric arguments or return numeric results,
Xthe arguments and results are passed as strings.
XMany commands expect their string arguments to have certain formats,
Xbut this interpretation is
Xup to the individual commands. For example, arguments often contain
XTcl command strings, which may get executed as part of the commands.
XThe easiest way to understand the Tcl interpreter is to remember that
Xeverything is just an operation on a string. In many cases Tcl constructs
Xwill look similar to more structured constructs from other languages.
XHowever, the Tcl constructs
Xare not structured at all; they are just strings of characters, and this
Xgives them a different behavior than the structures they may look like.
X.PP
XAlthough the exact interpretation of a Tcl string depends on who is
Xdoing the interpretation, there are three common forms that strings
Xtake: commands, expressions, and lists. The major sections below
Xdiscuss these three forms in more detail.
X
X.SH "BASIC COMMAND SYNTAX"
X.PP
XThe Tcl language has syntactic similarities to both the Unix shells
Xand Lisp. However, the interpretation of commands is different
Xin Tcl than in either of those other two systems.
XA Tcl command string consists of one or more commands separated
Xby newline characters or semi-colons.
XEach command consists of a collection of fields separated by
Xwhite space (spaces or tabs).
XThe first field must be the name of a command, and the
Xadditional fields, if any, are arguments that will be passed to
Xthat command. For example, the command
X.DS
X\fBset a 22\fR
X.DE
Xhas three fields: the first, \fBset\fR, is the name of a Tcl command, and
Xthe last two, \fBa\fR and \fB22\fR, will be passed as arguments to
Xthe \fBset\fR command. The command name may refer either to a built-in
XTcl command, an application-specific command bound in with the library
Xprocedure \fBTcl_CreateCommand\fR, or a command procedure defined with the
X\fBproc\fR built-in command.
XArguments are passed literally as
Xtext strings. Individual commands may interpret those strings in any
Xfashion they wish. The \fBset\fR command, for example, will treat its
Xfirst argument as the name of a variable and its second argument as a
Xstring value to assign to that variable. For other commands arguments
Xmay be interpreted as integers, lists, file names, or Tcl commands.
X.PP
X.VS
XCommand names should normally be typed completely (e.g. no abbreviations).
XHowever, if the Tcl interpreter cannot locate a command it invokes a
Xspecial command named \fBunknown\fR which attempts to find or create
Xthe command.
XFor example, at many sites \fBunknown\fR will search
Xthrough library directories for the desired command and create it
Xas a Tcl procedure if it is found.
XThe \fBunknown\fR command often provides automatic completion of
Xabbreviated commands, but usually only for commands that were typed
Xinteractively.
XIt's probably a bad idea to use abbreviations in command scripts
Xand other forms that will be re-used over time: changes
Xto the command set may cause abbreviations to become ambiguous,
Xresulting in scripts that no longer work.
X.VE
X
X.SH "COMMENTS"
X.PP
XIf the first non-blank character in a command is \fB#\fR, then everything
Xfrom the \fB#\fR up through the next newline character is treated as
Xa comment and ignored. When comments are embedded inside nested
Xcommands (e.g. fields enclosed in braces) they must have properly-matched
Xbraces (this is necessary because when Tcl parses the top-level command
Xit doesn't yet know that the nested field will be used as a command so
Xit cannot process the nested comment character as a comment).
X
X.SH "GROUPING ARGUMENTS WITH DOUBLE-QUOTES"
X.PP
XNormally each argument field ends at the next white space, but
Xdouble-quotes may be used to create arguments with embedded
Xspace. If an argument
Xfield begins with a double-quote, then the argument isn't
Xterminated by white space (including newlines) or a semi-colon
X(see below for information on semi-colons); instead it ends at the next
Xdouble-quote character. The double-quotes are not included
Xin the resulting argument. For example, the
Xcommand
X.DS
X\fBset a "This is a single argument"\fR
X.DE
Xwill pass two arguments to \fBset\fR: \fBa\fR and
X\fBThis is a single argument\fR. Within double-quotes, command
Xsubstitutions, variable substitutions, and backslash substitutions
Xstill occur, as described below. If the first character of a
Xcommand field is not a quote, then quotes receive no special
Xinterpretation in the parsing of that field.
X
X.SH "GROUPING ARGUMENTS WITH BRACES"
X.PP
XCurly braces may also be used for grouping arguments. They are
Xsimilar to quotes except for two differences. First, they nest;
Xthis makes them easier to use for complicated arguments like nested Tcl
Xcommand strings. Second, the substitutions described below for
Xcommands, variables, and backslashes do \fInot\fR occur in arguments
Xenclosed in braces, so braces can be used to prevent substitutions
Xwhere they are undesirable.
XIf an argument field
Xbegins with a left brace, then the argument ends at the matching
Xright brace. Tcl will strip off the outermost layer of braces
Xand pass the information between the braces to the command without
Xany further modification. For example, in the command
X.DS
X\fBset a {xyz a {b c d}}\fR
X.DE
Xthe \fBset\fR command will receive two arguments: \fBa\fR
Xand \fBxyz a {b c d}\fR.
X.PP
XWhen braces or quotes are in effect, the matching brace
Xor quote need not be on
Xthe same line as the starting quote or brace; in this case
Xthe newline will be
Xincluded in the argument field along with any other characters up to the
Xmatching brace or quote. For example, the \fBeval\fR command
Xtakes one
Xargument, which is a command string; \fBeval\fR invokes the Tcl
Xinterpreter to execute the command string. The command
X.DS
X\fBeval {
X set a 22
X set b 33
X}\fR
X.DE
Xwill assign the value \fB22\fR to \fBa\fR and \fB33\fR to \fBb\fR.
X.PP
XIf the first character of a command field is not a left
Xbrace, then neither left nor right
Xbraces in the field will be treated specially (except as part of
Xvariable substitution; see below).
X
X.SH "COMMAND SUBSTITUTION WITH BRACKETS"
X.PP
XIf an open bracket occurs in a field of a command, then
Xcommand substitution occurs (except for fields enclosed in
Xbraces). All of the text up to the matching
Xclose bracket is treated as a Tcl command and executed immediately.
XThen the result of that command is substituted for the bracketed
Xtext. For example, consider the command
X.DS
X\fBset a [set b]\fR
X.DE
XWhen the \fBset\fR command has only a single argument, it is the
Xname of a variable and \fBset\fR returns the contents of that
Xvariable. In this case, if variable \fBb\fR has the value \fBfoo\fR,
Xthen the command above is equivalent to the command
X.DS
X\fBset a foo\fR
X.DE
XBrackets can be used in more complex ways. For example, if the
Xvariable \fBb\fR has the value \fBfoo\fR and the variable \fBc\fR
Xhas the value \fBgorp\fR, then the command
X.DS
X\fBset a xyz[set b].[set c]\fR
X.DE
Xis equivalent to the command
X.DS
X\fBset a xyzfoo.gorp\fR
X.DE
X.VS
XA bracketed command may contain multiple commands separated by
Xnewlines or semi-colons in the usual fashion.
XIn this case the value of the last command is used for substitution.
XFor example, the command
X.DS
X\fBset a x[set b 22
Xexpr $b+2]x\fR
X.DE
Xis equivalent to the command
X.DS
X\fBset a x24x\fR
X.DE
X.VE
XIf a field is enclosed in braces then the brackets and the characters
Xbetween them are not interpreted specially; they are passed through
Xto the argument verbatim.
X
X.SH "VARIABLE SUBSTITUTION WITH $"
X.PP
XThe dollar sign (\fB$\fR) may be used as a special shorthand form
Xfor substituting variable values.
XIf \fB$\fR appears in an argument that isn't enclosed in braces
Xthen variable substitution will occur. The characters after
Xthe \fB$\fR, up to the first character that isn't a number, letter, or
Xunderscore, are taken as a variable name and the string value of that
Xvariable is substituted for the name.
X.VS
XFor example, if variable \fBfoo\fR
Xhas the value \fBtest\fR, then the command
X.DS C
X\fBset a $foo.c\fR
X.DE
Xis equivalent to the command
X.DS C
X\fBset a test.c\fR
X.DE
X.PP
XThere are two special forms for variable substitution.
XIf the next character after the name of the variable is an
Xopen parenthesis, then the variable is assumed to be an array
Xname, and all of the characters between the open parenthesis
Xand the next close parenthesis are taken as an index into the array.
XCommand substitutions and variable substitutions are
Xperformed on the information between the parentheses before it is
Xused as an index.
XFor example, if the variable \fBx\fR is an array with one element
Xnamed \fBfirst\fR and value \fB87\fR and another element named
X\fB14\fR and value \fBmore\fR, then the command
X.DS C
X\fBset a xyz$x(first)zyx
X.DE
Xis equivalent to the command
X.DS C
X\fBset a xyz87zyx\fR
X.DE
XIf the variable \fBindex\fR has the value \fB14\fR, then the command
X.DS C
X\fBset a xyz$x($index)zyx
X.DE
Xis equivalent to the command
X.DS C
X\fBset a xyzmorezyx
X.DE
XFor more information on arrays, see VARIABLES AND ARRAYS below.
X.PP
XThe second special form for variables occurs when
Xthe dollar sign is followed by an open curly brace.
XIn this case the variable name consists of all the characters
Xup to the next curly brace.
XArray references are not possible in this form: the name
Xbetween braces is assumed to refer to a scalar variable.
XFor example, if variable \fBfoo\fR has the value \fBtest\fR,
Xthen the command
X.DS C
X\fBset a abc${foo}bar\fR
X.DE
Xis equivalent to the command
X.DS C
X\fBset a abctestbar\fR
X.DE
X.VE
XVariable substitution does not occur in arguments that are enclosed
Xin braces: the
Xdollar sign and variable name are passed through to the argument verbatim.
X.PP
XThe dollar sign abbreviation is simply a shorthand form. \fB$a\fR is
Xcompletely equivalent to \fB[set a]\fR; it is provided as a convenience
Xto reduce typing.
X
X.SH "SEPARATING COMMANDS WITH SEMI-COLONS"
X.PP
XNormally, each command occupies one line (the command is terminated by
Xa newline character). However, semi-colon (``;'') is treated
Xas a command separator character; multiple commands may be placed
Xon one line by separating them with a semi-colon. Semi-colons are
Xnot treated as command separators if they appear within curly braces
Xor double-quotes.
X
X.SH "BACKSLASH SUBSTITUTION"
X.PP
XBackslashes may be used to insert non-printing characters into
Xcommand fields and also to insert special characters like
Xbraces and brackets into fields
Xwithout them being interpreted specially as described above.
XThe backslash sequences understood by the Tcl interpreter are
Xlisted below. In each case, the backslash
Xsequence is replaced by the given character:
X.TP 20
X\fB\eb\fR
XBackspace (0x8).
X.TP 20
X\fB\ef\fR
XForm feed (0xc).
X.TP 20
X\fB\en\fR
XNewline (0xa).
X.TP 20
X\fB\er\fR
XCarriage-return (0xd).
X.TP 20
X\fB\et\fR
XTab (0x9).
X.TP 20
X\fB\ev\fR
XVertical tab (0xb).
X.TP 20
X\fB\e{\fR
XLeft brace (``{'').
X.TP 20
X\fB\e}\fR
XRight brace (``}'').
X.TP 20
X\fB\e[\fR
XOpen bracket (``['').
X.TP 20
X\fB\e]\fR
XClose bracket (``]'').
X.TP 20
X\fB\e$\fR
XDollar sign (``$'').
X.TP 20
X\fB\e<space>\fR
XSpace (`` ''): doesn't terminate argument.
X.br
X.TP 20
X\fB\e;\fR
XSemi-colon: doesn't terminate command.
X.TP 20
X\fB\e"\fR
XDouble-quote.
X.TP 20
X\fB\e<newline>\fR
XNothing: this joins two lines together
Xinto a single line. This backslash feature is unique in that
Xit will be applied even when the sequence occurs within braces.
X.TP 20
X\fB\e\e\fR
XBackslash (``\e'').
X.TP 20
X\fB\e\fIddd\fR
XThe digits \fIddd\fR (one, two, or three of them) give the octal value of
Xthe character. Null characters may not be embedded in command fields;
Xif \fIddd\fR is zero then the backslash sequence is ignored (i.e. it
Xmaps to an empty string).
X.PP
XFor example, in the command
X.DS
X\fBset a \e{x\e[\e\0yz\e141\fR
X.DE
Xthe second argument to \fBset\fR will be ``\fB{x[\0yza\fR''.
X.PP
XIf a backslash is followed by something other than one of the options
Xdescribed above, then the backslash is transmitted to the argument
Xfield without any special processing, and the Tcl scanner continues
Xnormal processing with the next character. For example, in the
Xcommand
X.DS
X\fBset \e*a \e\e\e{foo\fR
X.DE
XThe first argument to \fBset\fR will be \fB\e*a\fR and the second
Xargument will be \fB\e{foo\fR.
X.PP
XIf an argument is enclosed in braces, then backslash sequences inside
Xthe argument are parsed but no substitution occurs (except for
Xbackslash-newline): the backslash
Xsequence is passed through to the argument as is, without making
Xany special interpretation of the characters in the backslash sequence.
XIn particular, backslashed braces are not counted in locating the
Xmatching right brace that terminates the argument.
XFor example, in the
Xcommand
X.DS
X\fBset a {\e{abc}\fR
X.DE
Xthe second argument to \fBset\fR will be \fB\e{abc\fR.
X.PP
XThis backslash mechanism is not sufficient to generate absolutely
Xany argument structure; it only covers the
Xmost common cases. To produce particularly complicated arguments
Xit is probably easiest to use the \fBformat\fR command along with
Xcommand substitution.
X
X.SH "COMMAND SUMMARY"
X.IP [1]
XA command is just a string.
X.IP [2]
XWithin a string commands are separated by newlines or semi-colons
X(unless the newline or semi-colon is within braces or brackets
Xor is backslashed).
X.IP [3]
XA command consists of fields. The first field is the name of the command,
Xand may be abbreviated.
XThe other fields are strings that are passed to that command as arguments.
X.IP [4]
XFields are normally separated by white space.
X.IP [5]
XDouble-quotes allow white space and semi-colons to appear within
Xa single argument.
XCommand substitution, variable substitution, and backslash substitution
Xstill occur inside quotes.
X.IP [6]
XBraces defer interpretation of special characters.
XIf a field begins with a left brace, then it consists of everything
Xbetween the left brace and the matching right brace. The
Xbraces themselves are not included in the argument.
XNo further processing is done on the information between the braces
Xexcept that backslash-newline sequences are eliminated.
X.IP [7]
XIf a field doesn't begin with a brace then backslash,
Xvariable, and command substitution are done on the field. Only a
Xsingle level of processing is done: the results of one substitution
Xare not scanned again for further substitutions or any other
Xspecial treatment. Substitution can
Xoccur on any field of a command, including the command name
Xas well as the arguments.
X.IP [8]
XIf the first non-blank character of a command is a \fB#\fR, everything
Xfrom the \fB#\fR up through the next newline is treated as a comment
Xand ignored.
X
X.SH "EXPRESSIONS"
X.VS
X.PP
XThe second major interpretation applied to strings in Tcl is
Xas expressions. Several commands, such as \fBexpr\fR, \fBfor\fR,
Xand \fBif\fR, treat one or more of their arguments as expressions
Xand call the Tcl expression processors (\fBTcl_ExprLong\fR,
X\fBTcl_ExprBoolean\fR, etc.) to evaluate them.
XThe operators permitted in Tcl expressions are a subset of
Xthe operators permitted in C expressions, and they have the
Xsame meaning and precedence as the corresponding C operators.
XExpressions almost always yield numeric results
X(integer or floating-point values).
XFor example, the expression
X.DS
X\fB8.2 + 6\fR
X.DE
Xevaluates to 14.2.
XTcl expressions differ from C expressions in the way that
Xoperands are specified, and in that Tcl expressions support
Xnon-numeric operands and string comparisons.
X.PP
XA Tcl expression consists of a combination of operands, operators,
Xand parentheses.
XWhite space may be used between the operands and operators and
Xparentheses; it is ignored by the expression processor.
XWhere possible, operands are interpreted as integer values.
XInteger values may be specified in decimal (the normal case), in octal (if the
Xfirst character of the operand is \fB0\fR), or in hexadecimal (if the first
Xtwo characters of the operand are \fB0x\fR).
XIf an operand does not have one of the integer formats given
Xabove, then it is treated as a floating-point number if that is
Xpossible. Floating-point numbers may be specified in any of the
Xways accepted by an ANSI-compliant C compiler (except that the
X``f'', ``F'', ``l'', and ``L'' suffixes will not be permitted in
Xmost installations). For example, all of the
Xfollowing are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
XIf no numeric interpretation is possible, then an operand is left
Xas a string (and only a limited set of operators may be applied to
Xit).
X.PP
XOperators may be specified in any of the following ways:
X.IP [1]
XAs an numeric value, either integer or floating-point.
X.IP [2]
XAs a Tcl variable, using standard \fB$\fR notation.
XThe variable's value will be used as the operand.
X.IP [3]
XAs a string enclosed in double-quotes.
XThe expression parser will perform backslash, variable, and
Xcommand substitutions on the information between the quotes,
Xand use the resulting value as the operand
X.IP [4]
XAs a string enclosed in braces.
XThe characters between the open brace and matching close brace
Xwill be used as the operand without any substitutions.
X.IP [5]
XAs a Tcl command enclosed in brackets.
XThe command will be executed and its result will be used as
Xthe operand.
X.IP [6]
XAn unquoted string consisting of any number of letters, digits,
Xand underscores (but a digit may not be the first character).
X.LP
XWhere substitutions occur above (e.g. inside quoted strings), they
Xare performed by the expression processor.
XHowever, an additional layer of substitution may already have
Xbeen performed by the command parser before the expression
Xprocessor was called.
XAs discussed below, it is usually best to enclose expressions
Xin braces to prevent the command parser from performing substitutions
Xon the contents.
X.PP
XFor some examples of simple expressions, suppose the variable
X\fBa\fR has the value 3 and
Xthe variable \fBb\fR has the value 6.
XThen the expression on the left side of each of the lines below
Xwill evaluate to the value on the right side of the line:
X.DS
X.ta 6c
X\fB3.1 + $a 6.1
X2 + "$a.$b" 5.6
X4*[length "6 2"] 8
X{word one} < "word $a" 0\fR
X.DE
X.PP
XThe valid operators are listed below, grouped in decreasing order
Xof precedence:
X.TP 20
X\fB\-\0\0~\0\0!\fR
XUnary minus, bit-wise NOT, logical NOT. None of these operands
Xmay be applied to string operands, and bit-wise NOT may be
Xapplied only to integers.
X.TP 20
X\fB*\0\0/\0\0%\fR
XMultiply, divide, remainder. None of these operands may be
Xapplied to string operands, and remainder may be applied only
Xto integers.
X.TP 20
X\fB+\0\0\-\fR
XAdd and subtract. Valid for any numeric operands.
X.TP 20
X\fB<<\0\0>>\fR
XLeft and right shift. Valid for integer operands only.
X.TP 20
X\fB<\0\0>\0\0<=\0\0>=\fR
XBoolean less, greater, less than or equal, and greater than or equal.
XEach operator produces 1 if the condition is true, 0 otherwise.
XThese operators may be applied to strings as well as numeric operands,
Xin which case string comparison is used.
X.TP 20
X\fB==\0\0!=\fR
XBoolean equal and not equal. Each operator produces a zero/one result.
XValid for all operand types.
X.TP 20
X\fB&\fR
XBit-wise AND. Valid for integer operands only.
X.TP 20
X\fB^\fR
XBit-wise exclusive OR. Valid for integer operands only.
X.TP 20
X\fB|\fR
XBit-wise OR. Valid for integer operands only.
X.TP 20
X\fB&&\fR
XLogical AND. Produces a 1 result if both operands are non-zero, 0 otherwise.
XValid for numeric operands only (integers or floating-point).
X.TP 20
X\fB||\fR
XLogical OR. Produces a 0 result if both operands are zero, 1 otherwise.
XValid for numeric operands only (integers or floating-point).
X.TP 20
X\fIx\fB?\fIy\fB:\fIz\fR
XIf-then-else, as in C. If \fIx\fR
Xevaluates to non-zero, then the result is the value of \fIy\fR.
XOtherwise the result is the value of \fIz\fR.
XThe \fIx\fR operand must have a numeric value.
X.LP
XSee the C manual for more details on the results
Xproduced by each operator.
XAll of the binary operators group left-to-right within the same
Xprecedence level. For example, the expression
X.DS
X\fB4*2 < 7\fR
X.DE
Xevaluates to 0.
X.PP
XThe \fB&&\fP, \fB||\fP, and \fB?:\fP operators have ``lazy
Xevaluation'', just as in C,
Xwhich means that operands are not evaluated if they are
Xnot needed to determine the outcome. For example, in
X.DS
X\fB$v ? [a] : [b]\fR
X.DE
Xonly one of \fB[a]\fR or \fB[b]\fR will actually be evaluated,
Xdepending on the value of \fB$v\fP.
X.PP
XAll internal computations involving integers are done with the C type
X\fIlong\fP, and all internal computations involving floating-point are
Xdone with the C type \fIdouble\fP.
XWhen converting a string to floating-point, exponent overflow is
Xdetected and results in a Tcl error.
XFor conversion to integer from string, detection of overflow depends
Xon the behavior of some routines in the local C library, so it should
Xbe regarded as unreliable.
XIn any case, overflow and underflow are generally not detected
Xreliably for intermediate results.
X.PP
XConversion among internal representations for integer, floating-point,
Xand string operands is done automatically as needed.
XFor arithmetic computations, integers are used until some
Xfloating-point number is introduced, after which floating-point is used.
XFor example,
X.DS
X\fB5 / 4\fR
X.DE
Xyields the result 1, while
X.DS
X\fB5 / 4.0\fR
X\fB5 / ( [length "abcd" chars] + 0.0 )
X.DE
Xboth yield the result 1.25.
X.PP
XString values may be used as operands of the comparison operators,
Xalthough the expression evaluator tries to do comparisons as integer
Xor floating-point when it can.
XIf one of the operands of a comparison is a string and the other
Xhas a numeric value, the numeric operand is converted back to
Xa string using the C \fIsprintf\fP format specifier
X\fB%d\fR for integers and \fB%g\fR for floating-point values.
XFor example, the expressions
X.DS
X\fB"0x03" > "2"\fR
X\fB"0y" < "0x12"\fR
X.DE
Xboth evaluate to 1. The first comparison is done using integer
Xcomparison, and the second is done using string comparison after
Xthe second operand is converted to the string ``18''.
X.VE
X.PP
XIn general it is safest to enclose an expression in braces when
Xentering it in a command: otherwise, if the expression contains
Xany white space then the Tcl interpreter will split it
Xamong several arguments. For example, the command
X.DS C
X\fBexpr $a + $b\fR
X.DE
Xresults in three arguments being passed to \fBexpr\fR: \fB$a\fR,
X\fB+\fR, and \fB$b\fR. In addition, if the expression isn't in braces
Xthen the Tcl interpreter will perform variable and command substitution
Ximmediately (it will happen in the command parser rather than in
Xthe expression parser). In many cases the expression is being
Xpassed to a command that will evaluate the expression later (or
Xeven many times if, for example, the expression is to be used to
Xdecide when to exit a loop). Usually the desired goal is to re-do
Xthe variable or command substitutions each time the expression is
Xevaluated, rather than once and for all at the beginning. For example,
Xthe command
X.DS C
X.ta 7c
X\fBfor {set i 1} $i<=10 {incr i} {...}\fR *** WRONG ***
X.DE
Xis probably intended to iterate over all values of \fBi\fR from 1 to 10.
XAfter each iteration of the body of the loop, \fBfor\fR will pass
Xits second argument to the expression evaluator to see whether or not
Xto continue processing. Unfortunately, in this case the value of \fBi\fR
Xin the second argument will be substituted once and for all when the
X\fBfor\fR command is parsed. If \fBi\fR was 0 before the \fBfor\fR
Xcommand was invoked then \fBfor\fR's second argument will be \fB0<=10\fR
Xwhich will always evaluate to 1, even though \fBi\fR's value eventually
Xbecomes greater than 10. In the above case the loop will never
Xterminate. Instead, the expression should be placed in braces:
X.DS C
X.ta 7c
X\fBfor {set i 1} {$i<=10} {incr i} {...}\fR *** RIGHT ***
X.DE
XThis causes the substitution of \fBi\fR's
Xvalue to be delayed; it will be re-done each time the expression is
Xevaluated, which is the desired result.
X
X.SH LISTS
X.PP
XThe third major way that strings are interpreted in Tcl is as lists.
XA list is just a string with a list-like structure
Xconsisting of fields separated by white space. For example, the
Xstring
X.DS
X\fBAl Sue Anne John\fR
X.DE
Xis a list with four elements or fields.
XLists have the same basic structure as command strings, except
Xthat a newline character in a list is treated as a field separator
Xjust like space or tab. Conventions for braces and quotes
Xand backslashes are the same for lists as for commands. For example,
Xthe string
X.DS
X\fBa b\e c {d e {f g h}}\fR
X.DE
Xis a list with three elements: \fBa\fR, \fBb c\fR, and \fBd e {f g h}\fR.
XWhenever an element
Xis extracted from a list, the same rules about braces and quotes and
Xbackslashes are applied as for commands. Thus in the example above
Xwhen the third element is extracted from the list, the result is
X.DS
X\fBd e {f g h}\fR
X.DE
X(when the field was extracted, all that happened was to strip off
Xthe outermost layer of braces). Command substitution and
Xvariable substitution are never
Xmade on a list (at least, not by the list-processing commands; the
Xlist can always be passed to the Tcl interpreter for evaluation).
X.PP
XThe Tcl commands \fBconcat\fR, \fBforeach\fR,
X.VS
X\fBlappend\fR, \fBlindex\fR, \fBlinsert\fR, \fBlist\fR, \fBllength\fR,
X\fBlrange\fR, \fBlreplace\fR, \fBlsearch\fR, and \fBlsort\fR allow
Xyou to build lists,
X.VE
Xextract elements from them, search them, and perform other list-related
Xfunctions.
X
X.SH "REGULAR EXPRESSIONS"
X.VS
X.PP
XTcl provides two commands that support string matching using
X\fBegrep\fR-style regular expressions: \fBregexp\fR and \fBregsub\fR.
XRegular expressions are implemented using Henry Spencer's package,
Xand the description of regular expressions below is copied verbatim
Xfrom his manual entry.
X.PP
XA regular expression is zero or more \fIbranches\fR, separated by ``|''.
XIt matches anything that matches one of the branches.
X.PP
XA branch is zero or more \fIpieces\fR, concatenated.
XIt matches a match for the first, followed by a match for the second, etc.
X.PP
XA piece is an \fIatom\fR possibly followed by ``*'', ``+'', or ``?''.
XAn atom followed by ``*'' matches a sequence of 0 or more matches of the atom.
XAn atom followed by ``+'' matches a sequence of 1 or more matches of the atom.
XAn atom followed by ``?'' matches a match of the atom, or the null string.
X.PP
XAn atom is a regular expression in parentheses (matching a match for the
Xregular expression), a \fIrange\fR (see below), ``.''
X(matching any single character), ``^'' (matching the null string at the
Xbeginning of the input string), ``$'' (matching the null string at the
Xend of the input string), a ``\e'' followed by a single character (matching
Xthat character), or a single character with no other significance
X(matching that character).
X.PP
XA \fIrange\fR is a sequence of characters enclosed in ``[]''.
XIt normally matches any single character from the sequence.
XIf the sequence begins with ``^'',
Xit matches any single character \fInot\fR from the rest of the sequence.
XIf two characters in the sequence are separated by ``\-'', this is shorthand
Xfor the full list of ASCII characters between them
X(e.g. ``[0-9]'' matches any decimal digit).
XTo include a literal ``]'' in the sequence, make it the first character
X(following a possible ``^'').
XTo include a literal ``\-'', make it the first or last character.
END_OF_FILE
if test 35297 -ne `wc -c <'tcl6.1/doc/Tcl.man.1'`; then
echo shar: \"'tcl6.1/doc/Tcl.man.1'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Tcl.man.1'
fi
echo shar: End of archive 27 $of 33$.
cp /dev/null ark27isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:58:40 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 96
Archive-name: tcl/part28
Environment: UNIX

# "End of archive 28 (of 33)."
# Contents: tcl6.1/tclCmdMZ.c
# Wrapped by karl@one on Tue Nov 12 19:44:31 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclCmdMZ.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclCmdMZ.c'\"
else
echo shar: Extracting \"'tcl6.1/tclCmdMZ.c'\" $35722 characters$
sed "s/^X//" >'tcl6.1/tclCmdMZ.c' <<'END_OF_FILE'
X/*
X * tclCmdMZ.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 * M to Z. It contains only commands in the generic core (i.e.
X * those that don't depend much upon UNIX facilities).

X *
X * Copyright 1987-1991 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: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.12 91/10/27 16:17:07 ouster Exp $ SPRITE (Berkeley)";

X#endif
X
X#include "tclInt.h"
X

X/*
X * Structure used to hold information about variable traces:

X */
X
Xtypedef struct {

X int flags; /* Operations for which Tcl command is
X * to be invoked. */
X int length; /* Number of non-NULL chars. in command. */
X char command[4]; /* Space for Tcl command to invoke. Actual
X * size will be as large as necessary to
X * hold command. This field must be the
X * last in the structure, so that it can
X * be larger than 4 bytes. */
X} TraceVarInfo;
X
X/*
X * Forward declarations for procedures defined in this file:
X */
X
Xstatic char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
X Tcl_Interp *interp, char *name1, char *name2,
X int flags));

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_RegexpCmd --
X *
X * This procedure is invoked to process the "regexp" 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_RegexpCmd(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 noCase = 0;
X int indices = 0;
X regexp *regexpPtr;
X char **argPtr, *string;
X int match, i;
X
X if (argc < 3) {
X wrongNumArgs:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?-nocase? exp string ?matchVar? ?subMatchVar ",
X "subMatchVar ...?\"", (char *) NULL);
X return TCL_ERROR;
X }
X argPtr = argv+1;
X argc--;
X while ((argc > 0) && (argPtr[0][0] == '-')) {
X if (strcmp(argPtr[0], "-indices") == 0) {
X argPtr++;
X argc--;
X indices = 1;
X } else if (strcmp(argPtr[0], "-nocase") == 0) {
X argPtr++;
X argc--;
X noCase = 1;
X } else {
X break;
X }
X }
X if (argc < 2) {
X goto wrongNumArgs;
X }
X regexpPtr = TclCompileRegexp(interp, argPtr[0]);
X if (regexpPtr == NULL) {

X return TCL_ERROR;
X }
X

X /*
X * Convert the string to lower case, if desired, and perform
X * the match.
X */
X
X if (noCase) {
X register char *dst, *src;
X
X string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
X for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
X if (isupper(*src)) {
X *dst = tolower(*src);
X } else {

X *dst = *src;
X }

X }
X *dst = 0;
X } else {
X string = argPtr[1];
X }
X tclRegexpError = NULL;
X match = regexec(regexpPtr, string);
X if (string != argPtr[1]) {
X ckfree(string);
X }
X if (tclRegexpError != NULL) {
X Tcl_AppendResult(interp, "error while matching pattern: ",
X tclRegexpError, (char *) NULL);
X return TCL_ERROR;
X }
X if (!match) {
X interp->result = "0";

X return TCL_OK;
X }
X

X /*
X * If additional variable names have been specified, return
X * index information in those variables.
X */

X
X argc -= 2;

X if (argc > NSUBEXP) {
X interp->result = "too many substring variables";
X return TCL_ERROR;
X }
X for (i = 0; i < argc; i++) {
X char *result, info[50];
X
X if (regexpPtr->startp[i] == NULL) {
X if (indices) {
X result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
X } else {
X result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
X }
X } else {
X if (indices) {
X sprintf(info, "%d %d", regexpPtr->startp[i] - string,
X regexpPtr->endp[i] - string - 1);
X result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
X } else {
X char savedChar, *first, *last;
X
X first = argPtr[1] + (regexpPtr->startp[i] - string);
X last = argPtr[1] + (regexpPtr->endp[i] - string);
X savedChar = *last;
X *last = 0;
X result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
X *last = savedChar;
X }
X }

X if (result == NULL) {

X Tcl_AppendResult(interp, "couldn't set variable \"",
X argPtr[i+2], "\"", (char *) NULL);

X return TCL_ERROR;
X }
X }

X interp->result = "1";

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_RegsubCmd --
X *
X * This procedure is invoked to process the "regsub" 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_RegsubCmd(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 noCase = 0, all = 0;
X regexp *regexpPtr;
X char *string, *p, *firstChar, *newValue, **argPtr;
X int match, result, flags;
X register char *src, c;
X
X if (argc < 5) {
X wrongNumArgs:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
X return TCL_ERROR;
X }
X argPtr = argv+1;
X argc--;
X while (argPtr[0][0] == '-') {
X if (strcmp(argPtr[0], "-nocase") == 0) {
X argPtr++;
X argc--;
X noCase = 1;
X } else if (strcmp(argPtr[0], "-all") == 0) {
X argPtr++;
X argc--;
X all = 1;
X } else {
X break;
X }
X }

X if (argc != 4) {

X goto wrongNumArgs;
X }
X regexpPtr = TclCompileRegexp(interp, argPtr[0]);
X if (regexpPtr == NULL) {

X return TCL_ERROR;
X }
X

X /*
X * Convert the string to lower case, if desired.
X */
X
X if (noCase) {

X register char *dst;
X

X string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
X for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
X if (isupper(*src)) {
X *dst = tolower(*src);
X } else {

X *dst = *src;
X }

X }
X *dst = 0;
X } else {
X string = argPtr[1];
X }
X
X /*
X * The following loop is to handle multiple matches within the
X * same source string; each iteration handles one match and its
X * corresponding substitution. If "-all" hasn't been specified
X * then the loop body only gets executed once.
X */
X
X flags = 0;
X for (p = string; *p != 0; ) {
X tclRegexpError = NULL;
X match = regexec(regexpPtr, p);
X if (tclRegexpError != NULL) {
X Tcl_AppendResult(interp, "error while matching pattern: ",
X tclRegexpError, (char *) NULL);

X result = TCL_ERROR;
X goto done;
X }

X if (!match) {
X break;
X }
X
X /*
X * Copy the portion of the source string before the match to the
X * result variable.
X */
X
X src = argPtr[1] + (regexpPtr->startp[0] - string);
X c = *src;
X *src = 0;
X newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
X flags);
X *src = c;
X flags = TCL_APPEND_VALUE;
X if (newValue == NULL) {
X cantSet:
X Tcl_AppendResult(interp, "couldn't set variable \"",
X argPtr[3], "\"", (char *) NULL);

X result = TCL_ERROR;
X goto done;
X }
X

X /*
X * Append the subSpec argument to the variable, making appropriate
X * substitutions. This code is a bit hairy because of the backslash
X * conventions and because the code saves up ranges of characters in
X * subSpec to reduce the number of calls to Tcl_SetVar.
X */
X
X for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
X int index;
X
X if (c == '&') {
X index = 0;

X } else if (c == '\\') {

X c = src[1];
X if ((c >= '0') && (c <= '9')) {
X index = c - '0';
X } else if ((c == '\\') || (c == '&')) {
X *src = c;
X src[1] = 0;
X newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
X TCL_APPEND_VALUE);
X *src = '\\';
X src[1] = c;
X if (newValue == NULL) {
X goto cantSet;
X }
X firstChar = src+2;
X src++;
X continue;
X } else {
X continue;
X }
X } else {
X continue;
X }
X if (firstChar != src) {
X c = *src;
X *src = 0;
X newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
X TCL_APPEND_VALUE);
X *src = c;
X if (newValue == NULL) {
X goto cantSet;
X }
X }
X if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
X && (regexpPtr->endp[index] != NULL)) {
X char *first, *last, saved;
X
X first = argPtr[1] + (regexpPtr->startp[index] - string);
X last = argPtr[1] + (regexpPtr->endp[index] - string);
X saved = *last;
X *last = 0;
X newValue = Tcl_SetVar(interp, argPtr[3], first,
X TCL_APPEND_VALUE);
X *last = saved;
X if (newValue == NULL) {
X goto cantSet;
X }
X }
X if (*src == '\\') {
X src++;
X }
X firstChar = src+1;
X }
X if (firstChar != src) {
X if (Tcl_SetVar(interp, argPtr[3], firstChar,
X TCL_APPEND_VALUE) == NULL) {
X goto cantSet;
X }
X }
X p = regexpPtr->endp[0];
X if (!all) {
X break;

X }
X }
X
X /*

X * If there were no matches at all, then return a "0" result.
X */
X
X if (p == string) {

X interp->result = "0";

X result = TCL_OK;
X goto done;
X }
X
X /*

X * Copy the portion of the source string after the last match to the
X * result variable.
X */
X
X if (*p != 0) {
X if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
X goto cantSet;

X }
X }
X interp->result = "1";

X result = TCL_OK;
X

X done:
X if (string != argPtr[1]) {
X ckfree(string);

X }
X return result;
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 *cmdPtr;

X Interp *iPtr = (Interp *) interp;

X Tcl_HashEntry *hPtr;
X int new;
X

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " oldName newName\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (argv[2][0] == '\0') {
X if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
X Tcl_AppendResult(interp, "can't delete \"", argv[1],
X "\": command doesn't exist", (char *) NULL);

X return TCL_ERROR;
X }
X return TCL_OK;
X }

X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
X if (hPtr != NULL) {
X Tcl_AppendResult(interp, "can't rename to \"", argv[2],
X "\": command already exists", (char *) NULL);
X return TCL_ERROR;
X }
X hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);

X if (hPtr == NULL) {

X Tcl_AppendResult(interp, "can't rename \"", argv[1],
X "\": command doesn't exist", (char *) NULL);
X return TCL_ERROR;
X }

X cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

X Tcl_DeleteHashEntry(hPtr);
X hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
X Tcl_SetHashValue(hPtr, cmdPtr);

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 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " ?value?\"", (char *) NULL);
X return TCL_ERROR;
X }

X if (argc == 2) {

X Tcl_SetResult(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, widthSpecified;

X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " string format ?varName varName ...?\"", (char *) NULL);

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 widthSpecified = 0;
X while (isdigit(*fmt)) {
X widthSpecified = 1;
X fmt++;
X }
X if (suppress) {
X continue;
X }
X if (numFields == MAX_FIELDS) {
X interp->result = "too many fields to scan";
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 if (widthSpecified) {
X interp->result =
X "field width may not be specified in %c conversion";
X return TCL_ERROR;
X }
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 = sizeof(double);
X break;
X
X case 'e':
X case 'f':
X curField->fmt = 'f';
X curField->size = sizeof(float);
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, fields[5].location,
X fields[6].location, fields[7].location, fields[8].location,
X fields[9].location, fields[10].location, fields[11].location,
X fields[12].location, fields[13].location, fields[14].location,
X fields[15].location, fields[16].location, fields[17].location,
X fields[18].location, fields[19].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[120];
X
X case 'd':
X sprintf(string, "%d", *((int *) curField->location));
X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
X storeError:
X Tcl_AppendResult(interp,
X "couldn't set variable \"", argv[i+3], "\"",
X (char *) NULL);
X ckfree((char *) results);
X return TCL_ERROR;
X }
X break;
X
X case 'c':
X sprintf(string, "%d", *((char *) curField->location) & 0xff);
X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
X goto storeError;
X }
X break;
X
X case 's':
X if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
X == NULL) {
X goto storeError;
X }
X break;
X
X case 'F':
X sprintf(string, "%g", *((double *) curField->location));
X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
X goto storeError;
X }
X break;
X
X case 'f':
X sprintf(string, "%g", *((float *) curField->location));
X if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
X goto storeError;

X }
X break;
X }
X }

X ckfree(results);
X sprintf(interp->result, "%d", numScanned);

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SplitCmd --
X *
X * This procedure is invoked to process the "split" 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_SplitCmd(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 *splitChars;
X register char *p, *p2;
X char *elementStart;

X
X if (argc == 2) {

X splitChars = " \n\t\r";

X } else if (argc == 3) {

X splitChars = argv[2];
X } else {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " string ?splitChars?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X /*
X * Handle the special case of splitting on every character.
X */
X
X if (*splitChars == 0) {
X char string[2];
X string[1] = 0;
X for (p = argv[1]; *p != 0; p++) {
X string[0] = *p;
X Tcl_AppendElement(interp, string, 0);

X }
X return TCL_OK;
X }
X
X /*

X * Normal case: split on any of a given set of characters.
X * Discard instances of the split characters.
X */
X
X for (p = elementStart = argv[1]; *p != 0; p++) {
X char c = *p;
X for (p2 = splitChars; *p2 != 0; p2++) {
X if (*p2 == c) {
X *p = 0;
X Tcl_AppendElement(interp, elementStart, 0);
X *p = c;
X elementStart = p+1;
X break;
X }
X }
X }
X if (p != argv[1]) {
X Tcl_AppendElement(interp, elementStart, 0);

X }
X return TCL_OK;
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 int left = 0, right = 0;

X
X if (argc < 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " option arg ?arg ...?\"", (char *) NULL);
X return TCL_ERROR;
X }

X c = argv[1][0];
X length = strlen(argv[1]);

X if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {

X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " compare string1 string2\"", (char *) NULL);
X return TCL_ERROR;
X }
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 } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {

X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " first string1 string2\"", (char *) NULL);
X return TCL_ERROR;
X }
X first = 1;
X
X firstLast:
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 } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
X int index;

X
X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " index string charIndex\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
X return TCL_ERROR;
X }
X if ((index >= 0) && (index < strlen(argv[2]))) {
X interp->result[0] = argv[2][index];
X interp->result[1] = 0;
X }
X return TCL_OK;
X } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)

X && (length >= 2)) {

X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " last string1 string2\"", (char *) NULL);
X return TCL_ERROR;
X }
X first = 0;
X goto firstLast;
X } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)

X && (length >= 2)) {

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " length string\"", (char *) NULL);
X return TCL_ERROR;
X }
X sprintf(interp->result, "%d", strlen(argv[2]));
X return TCL_OK;
X } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {

X if (argc != 4) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " match pattern string\"", (char *) NULL);
X return TCL_ERROR;
X }
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 if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
X int first, last, stringLength;
X
X if (argc != 5) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " range string first last\"", (char *) NULL);
X return TCL_ERROR;
X }
X stringLength = strlen(argv[2]);

X if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {

X return TCL_ERROR;
X }
X if ((*argv[4] == 'e')
X && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
X last = stringLength-1;
X } else {
X if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {

X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp,
X "expected integer or \"end\" but got \"",

X argv[4], "\"", (char *) NULL);

X return TCL_ERROR;
X }
X }

X if (first < 0) {

X first = 0;
X }

X if (last >= stringLength) {
X last = stringLength-1;
X }
X if (last >= first) {
X char saved, *p;
X
X p = argv[2] + last + 1;
X saved = *p;
X *p = 0;
X Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
X *p = saved;
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
X && (length >= 3)) {

X register char *p;
X

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " tolower string\"", (char *) NULL);
X return TCL_ERROR;
X }
X Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
X for (p = interp->result; *p != 0; p++) {
X if (isupper(*p)) {
X *p = tolower(*p);
X }
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
X && (length >= 3)) {

X register char *p;
X

X if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X " toupper string\"", (char *) NULL);
X return TCL_ERROR;
X }
X Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
X for (p = interp->result; *p != 0; p++) {
X if (islower(*p)) {
X *p = toupper(*p);
X }
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
X && (length == 4)) {
X char *trimChars;
X register char *p, *checkPtr;
X
X left = right = 1;
X
X trim:

X if (argc == 4) {

X trimChars = argv[3];

X } else if (argc == 3) {

X trimChars = " \t\n\r";
X } else {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ", argv[1], " string ?chars?\"", (char *) NULL);
X return TCL_ERROR;
X }
X p = argv[2];
X if (left) {
X for (c = *p; c != 0; p++, c = *p) {
X for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
X if (*checkPtr == 0) {
X goto doneLeft;
X }
X }
X }
X }
X doneLeft:
X Tcl_SetResult(interp, p, TCL_VOLATILE);
X if (right) {
X char *donePtr;
X
X p = interp->result + strlen(interp->result) - 1;
X donePtr = &interp->result[-1];
X for (c = *p; p != donePtr; p--, c = *p) {
X for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
X if (*checkPtr == 0) {
X goto doneRight;
X }
X }
X }
X doneRight:
X p[1] = 0;
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
X && (length > 4)) {
X left = 1;
X argv[1] = "trimleft";
X goto trim;
X } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
X && (length > 4)) {
X right = 1;
X argv[1] = "trimright";
X goto trim;

X } else {
X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": should be compare, first, index, last, length, match, ",
X "range, tolower, toupper, trim, trimleft, or trimright",
X (char *) NULL);
X return TCL_ERROR;

X }
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_TraceCmd --
X *
X * This procedure is invoked to process the "trace" 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_TraceCmd(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 c;
X int length;

X
X if (argc < 2) {

X Tcl_AppendResult(interp, "too few args: should be \"",
X argv[0], " option [arg arg ...]\"", (char *) NULL);
X return TCL_ERROR;
X }
X c = argv[1][1];

X length = strlen(argv[1]);

X if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)

X && (length >= 2)) {

X char *p;
X int flags, length;
X TraceVarInfo *tvarPtr;
X
X if (argc != 5) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " variable name ops command\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X flags = 0;
X for (p = argv[3] ; *p != 0; p++) {
X if (*p == 'r') {
X flags |= TCL_TRACE_READS;
X } else if (*p == 'w') {
X flags |= TCL_TRACE_WRITES;
X } else if (*p == 'u') {
X flags |= TCL_TRACE_UNSETS;
X } else {
X goto badOps;
X }
X }
X if (flags == 0) {
X goto badOps;
X }
X
X length = strlen(argv[4]);
X tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
X (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
X tvarPtr->flags = flags;
X tvarPtr->length = length;
X flags |= TCL_TRACE_UNSETS;
X strcpy(tvarPtr->command, argv[4]);
X if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
X (ClientData) tvarPtr) != TCL_OK) {
X ckfree((char *) tvarPtr);
X return TCL_ERROR;
X }
X } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
X && (length >= 2)) == 0) {
X char *p;
X int flags, length;
X TraceVarInfo *tvarPtr;
X ClientData clientData;
X
X if (argc != 5) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " vdelete name ops command\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X flags = 0;
X for (p = argv[3] ; *p != 0; p++) {
X if (*p == 'r') {
X flags |= TCL_TRACE_READS;
X } else if (*p == 'w') {
X flags |= TCL_TRACE_WRITES;
X } else if (*p == 'u') {
X flags |= TCL_TRACE_UNSETS;
X } else {
X goto badOps;
X }
X }
X if (flags == 0) {
X goto badOps;
X }
X
X /*
X * Search through all of our traces on this variable to
X * see if there's one with the given command. If so, then
X * delete the first one that matches.
X */
X
X length = strlen(argv[4]);
X clientData = 0;
X while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
X TraceVarProc, clientData)) != 0) {
X tvarPtr = (TraceVarInfo *) clientData;
X if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
X && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
X Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
X TraceVarProc, clientData);
X ckfree((char *) tvarPtr);
X break;
X }
X }
X } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)

X && (length >= 2)) {

X ClientData clientData;
X char ops[4], *p;
X char *prefix = "{";

X
X if (argc != 3) {
X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " vinfo name\"", (char *) NULL);
X return TCL_ERROR;
X }
X clientData = 0;
X while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
X TraceVarProc, clientData)) != 0) {
X TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
X p = ops;
X if (tvarPtr->flags & TCL_TRACE_READS) {
X *p = 'r';
X p++;
X }
X if (tvarPtr->flags & TCL_TRACE_WRITES) {
X *p = 'w';
X p++;
X }
X if (tvarPtr->flags & TCL_TRACE_UNSETS) {
X *p = 'u';
X p++;
X }
X *p = '\0';
X Tcl_AppendResult(interp, prefix, (char *) NULL);
X Tcl_AppendElement(interp, ops, 1);
X Tcl_AppendElement(interp, tvarPtr->command, 0);
X Tcl_AppendResult(interp, "}", (char *) NULL);
X tvarPtr->command[tvarPtr->length] = ' ';
X prefix = " {";
X }

X } else {
X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": should be variable, vdelete, or vinfo",
X (char *) NULL);

X return TCL_ERROR;
X }
X return TCL_OK;
X

X badOps:
X Tcl_AppendResult(interp, "bad operations \"", argv[3],
X "\": should be one or more of rwu", (char *) NULL);

X return TCL_ERROR;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * TraceVarProc --
X *
X * This procedure is called to handle variable accesses that have
X * been traced using the "trace" command.

X *
X * Results:

X * Normally returns NULL. If the trace command returns an error,
X * then this procedure returns an error string.
X *
X * Side effects:
X * Depends on the command associated with the trace.

X *
X *----------------------------------------------------------------------
X */
X

X /* ARGSUSED */
Xstatic char *
XTraceVarProc(clientData, interp, name1, name2, flags)
X ClientData clientData; /* Information about the variable trace. */

X Tcl_Interp *interp; /* Interpreter containing variable. */

X char *name1; /* Name of variable or array. */

X char *name2; /* Name of element within array; NULL means

X * scalar variable is being referenced. */
X int flags; /* OR-ed bits giving operation and other
X * information. */
X{
X TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
X char *result;
X int code, cmdLength, flags1, flags2;
X Interp dummy;
X#define STATIC_SIZE 199
X char staticSpace[STATIC_SIZE+1];
X char *cmdPtr, *p;
X
X result = NULL;
X if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
X
X /*
X * Generate a command to execute by appending list elements
X * for the two variable names and the operation. The five
X * extra characters are for three space, the opcode character,
X * and the terminating null.
X */
X
X if (name2 == NULL) {
X name2 = "";
X }
X cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
X Tcl_ScanElement(name2, &flags2) + 5;
X if (cmdLength < STATIC_SIZE) {
X cmdPtr = staticSpace;
X } else {
X cmdPtr = (char *) ckalloc((unsigned) cmdLength);
X }
X p = cmdPtr;
X strcpy(p, tvarPtr->command);
X p += tvarPtr->length;
X *p = ' ';
X p++;
X p += Tcl_ConvertElement(name1, p, flags1);
X *p = ' ';
X p++;
X p += Tcl_ConvertElement(name2, p, flags2);
X *p = ' ';
X if (flags & TCL_TRACE_READS) {
X p[1] = 'r';
X } else if (flags & TCL_TRACE_WRITES) {
X p[1] = 'w';
X } else if (flags & TCL_TRACE_UNSETS) {
X p[1] = 'u';
X }
X p[2] = '\0';
X
X /*
X * Execute the command. Be careful to save and restore the
X * result from the interpreter used for the command.
X */
X
X dummy.freeProc = interp->freeProc;
X if (interp->freeProc == 0) {
X Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
X } else {
X dummy.result = interp->result;
X }
X code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
X if (cmdPtr != staticSpace) {
X ckfree(cmdPtr);
X }
X if (code != TCL_OK) {
X result = "access disallowed by trace command";
X Tcl_ResetResult(interp); /* Must clear error state. */
X }
X Tcl_FreeResult(interp);
X interp->result = dummy.result;
X interp->freeProc = dummy.freeProc;
X }
X if (flags & TCL_TRACE_DESTROYED) {
X ckfree((char *) tvarPtr);

X }
X return result;
X}
X
X/*

X *----------------------------------------------------------------------
X *
X * Tcl_WhileCmd --
X *
X * This procedure is invoked to process the "while" 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_WhileCmd(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 != 3) {
X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], " test command\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X while (1) {
X result = Tcl_ExprBoolean(interp, argv[1], &value);

X if (result != TCL_OK) {
X return result;
X }

X if (!value) {
X break;
X }
X result = Tcl_Eval(interp, argv[2], 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, "\n (\"while\" body line %d)",
X interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);

X }
X break;
X }
X }

X if (result == TCL_BREAK) {

X result = TCL_OK;
X }

X if (result == TCL_OK) {

X Tcl_ResetResult(interp);

X }
X return result;
X}
END_OF_FILE

if test 35722 -ne `wc -c <'tcl6.1/tclCmdMZ.c'`; then
echo shar: \"'tcl6.1/tclCmdMZ.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclCmdMZ.c'
fi
echo shar: End of archive 28 $of 33$.
cp /dev/null ark28isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:59:11 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 97
Archive-name: tcl/part29
Environment: UNIX

# "End of archive 29 (of 33)."
# Contents: tcl6.1/tclUtil.c

# Wrapped by karl@one on Tue Nov 12 19:44:31 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclUtil.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclUtil.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUtil.c'\" $36390 characters$
sed "s/^X//" >'tcl6.1/tclUtil.c' <<'END_OF_FILE'
X/*
X * tclUtil.c --
X *
X * This file contains utility procedures that are used by many Tcl
X * commands.

Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.60 91/10/17 15:49:56 ouster Exp $ SPRITE (Berkeley)";

X#endif
X
X#include "tclInt.h"
X
X/*

X * The following values are used in the flags returned by Tcl_ScanElement
X * and used by Tcl_ConvertElement.
X */
X
X#define USE_BRACES 1
X#define CANT_USE_BRACES 2
X
X/*
X * The variable below is set to NULL before invoking regexp functions
X * and checked after those functions. If an error occurred then regerror
X * will set the variable to point to a (static) error message. This
X * mechanism unfortunately does not support multi-threading, but then
X * neither does the rest of the regexp facilities.
X */
X
Xchar *tclRegexpError = NULL;
X
X/*
X * Function prototypes for local procedures in this file:
X */
X
Xstatic void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
X int newSpace));

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 inQuotes = 0;
X int size;
X
X /*
X * Skim off leading white space and check for an opening brace or
X * quote. Note: use of "isascii" below and elsewhere in this
X * procedure is a temporary hack (7/27/90) because Mx uses characters
X * with the high-order bit set for some things. This should probably
X * be changed back eventually, or all of Tcl should call isascii.
X */
X
X while (isascii(*list) && isspace(*list)) {
X list++;
X }
X if (*list == '{') {
X openBraces = 1;
X list++;
X } else if (*list == '"') {
X inQuotes = 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 ((isascii(*p) && 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_ResetResult(interp);
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 or quotes; otherwise
X * terminate element.
X */
X
X case ' ':
X case '\f':
X case '\n':
X case '\r':
X case '\t':
X case '\v':
X if ((openBraces == 0) && !inQuotes) {
X size = p - list;
X goto done;
X }
X break;
X
X /*
X * Double-quote: if element is in quotes then terminate it.
X */
X
X case '"':
X if (inQuotes) {
X char *p2;
X
X size = p-list;
X p++;
X if ((isascii(*p) && 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_ResetResult(interp);
X sprintf(interp->result,

X "list element in quotes followed by \"%.*s\" %s",
X p2-p, p, "instead of space");

X return TCL_ERROR;
X }
X break;
X

X /*
X * End of list: terminate element.
X */
X
X case 0:
X if (openBraces != 0) {
X Tcl_SetResult(interp, "unmatched open brace in list",

X TCL_STATIC);
X return TCL_ERROR;

X } else if (inQuotes) {
X Tcl_SetResult(interp, "unmatched open quote 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 (isascii(*p) && 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 int count; /* Total number of characters to copy
X * from src. */
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; src++, c = *src, count--) {
X if (c == '\\') {

X *dst = Tcl_Backslash(src, &numRead);
X if (*dst != 0) {
X dst++;

X }
X src += numRead-1;
X count -= numRead-1;
X } else {
X *dst = c;
X dst++;

X }
X }
X *dst = 0;
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 free this memory by calling free()
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 size++; /* Leave space for final NULL pointer. */
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 ckfree((char *) argv);
X Tcl_SetResult(interp, "internal error in Tcl_SplitList",
X 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 argv[i] = NULL;
X *argvPtr = argv;
X *argcPtr = i;

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ScanElement --
X *
X * This procedure is a companion procedure to Tcl_ConvertElement.
X * It scans a string to see what needs to be done to it (e.g.
X * add backslashes or enclosing braces) to make the string into
X * a valid Tcl list element.

X *
X * Results:

X * The return value is an overestimate of the number of characters
X * that will be needed by Tcl_ConvertElement to produce a valid
X * list element from string. The word at *flagPtr is filled in
X * with a value needed by Tcl_ConvertElement when doing the actual
X * conversion.

X *
X * Side effects:

X * None.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_ScanElement(string, flagPtr)
X char *string; /* String to convert to Tcl list element. */
X int *flagPtr; /* Where to store information to guide
X * Tcl_ConvertElement. */
X{
X int flags, nestingLevel;

X register char *p;
X

X /*
X * This procedure and Tcl_ConvertElement together do two things:
X *
X * 1. They produces a proper list, one that will yield back the
X * argument strings when evaluated or when disassembled with
X * Tcl_SplitList. This is the most important thing.
X *
X * 2. They try to produce legible output, which means minimizing the
X * use of backslashes (using braces instead). However, there are
X * some situations where backslashes must be used (e.g. an element
X * like "{abc": the leading brace will have to be backslashed. For
X * each element, one of three things must be done:
X *
X * (a) Use the element as-is (it doesn't contain anything special
X * characters). This is the most desirable option.
X *
X * (b) Enclose the element in braces, but leave the contents alone.
X * This happens if the element contains embedded space, or if it
X * contains characters with special interpretation ($, [, ;, or \),
X * or if it starts with a brace or double-quote, or if there are
X * no characters in the element.
X *
X * (c) Don't enclose the element in braces, but add backslashes to
X * prevent special interpretation of special characters. This is a
X * last resort used when the argument would normally fall under case
X * (b) but contains unmatched braces. It also occurs if the last
X * character of the argument is a backslash.
X *
X * The procedure figures out how many bytes will be needed to store
X * the result (actually, it overestimates). It also collects information
X * about the element in the form of a flags word.
X */
X
X nestingLevel = 0;
X flags = 0;
X p = string;
X if ((*p == '{') || (*p == '"') || (*p == 0)) {
X flags |= USE_BRACES;
X }
X for ( ; *p != 0; p++) {
X switch (*p) {
X case '{':
X nestingLevel++;
X break;
X case '}':
X nestingLevel--;
X if (nestingLevel < 0) {
X flags |= CANT_USE_BRACES;
X }
X break;

X case '[':
X case '$':
X case ';':
X case ' ':

X case '\f':
X case '\n':
X case '\r':
X case '\t':
X case '\v':
X flags |= USE_BRACES;
X break;
X case '\\':
X if (p[1] == 0) {
X flags = CANT_USE_BRACES;
X } else {
X int size;
X
X (void) Tcl_Backslash(p, &size);
X p += size-1;
X flags |= USE_BRACES;

X }
X break;
X }
X }

X if ((nestingLevel != 0) || (flags & CANT_USE_BRACES)) {
X flags = CANT_USE_BRACES;
X }
X *flagPtr = flags;
X
X /*
X * Allow enough space to backslash every character plus leave
X * two spaces for braces.
X */
X
X return 2*(p-string) + 2;

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ConvertElement --
X *
X * This is a companion procedure to Tcl_ScanElement. Given the
X * information produced by Tcl_ScanElement, this procedure converts
X * a string to a list element equal to that string.
X *
X * Results:
X * Information is copied to *dst in the form of a list element
X * identical to src (i.e. if Tcl_SplitList is applied to dst it
X * will produce a string identical to src). The return value is
X * a count of the number of characters copied (not including the
X * terminating NULL character).

X *
X * Side effects:

X * None.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTcl_ConvertElement(src, dst, flags)
X register char *src; /* Source information for list element. */
X char *dst; /* Place to put list-ified element. */
X int flags; /* Flags produced by Tcl_ScanElement. */
X{
X register char *p = dst;
X
X /*
X * See the comment block at the beginning of the Tcl_ScanElement
X * code for details of how this works.
X */
X
X if (flags & USE_BRACES) {

X *p = '{';
X p++;

X for ( ; *src != 0; src++, p++) {
X *p = *src;
X }

X *p = '}';
X p++;

X } else {
X /*
X * Must backslash a leading open brace, but after that don't
X * need to worry about either open or close braces.
X */
X
X if (*src == '{') {

X *p = '\\';
X p++;
X }

X for (; *src != 0 ; src++) {
X switch (*src) {

X case ']':
X case '[':
X case '$':
X case ';':
X case ' ':

X case '\\':

X *p = '\\';
X p++;

X break;
X case '\f':

X *p = '\\';
X p++;

X *p = 'f';
X p++;
X continue;
X case '\n':

X *p = '\\';
X p++;

X *p = 'n';
X p++;
X continue;
X case '\r':

X *p = '\\';
X p++;

X *p = 'r';
X p++;

X continue;
X case '\t':

X *p = '\\';
X p++;

X *p = 't';
X p++;
X continue;
X case '\v':

X *p = '\\';
X p++;

X *p = 'v';
X p++;
X continue;
X }
X *p = *src;
X p++;
X }

X }
X *p = '\0';

X return p-dst;

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 * Tcl_SplitList may be used to retrieve strings equal to the
X * original elements, and Tcl_Eval will parse the string back
X * 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# define LOCAL_SIZE 20
X int localFlags[LOCAL_SIZE], *flagPtr;
X int numChars;
X char *result;
X register char *dst;
X int i;
X
X /*
X * Pass 1: estimate space, gather flags.
X */
X
X if (argc <= LOCAL_SIZE) {
X flagPtr = localFlags;
X } else {
X flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
X }
X numChars = 1;

X for (i = 0; i < argc; i++) {

X numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
X }
X
X /*
X * Pass two: copy into the result area.
X */
X
X result = (char *) ckalloc((unsigned) numChars);
X dst = result;

X for (i = 0; i < argc; i++) {

X numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
X dst += numChars;

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 if (argc == 0) {

X *result = '\0';
X return result;
X }
X for (p = result, i = 0; i < argc; i++) {
X char *element;
X int length;
X
X /*
X * Clip white space off the front and back of the string
X * to generate a neater result, and ignore any empty
X * elements.
X */
X
X element = argv[i];
X while (isspace(*element)) {
X element++;
X }
X for (length = strlen(element);
X (length > 0) && (isspace(element[length-1]));
X length--) {
X /* Null loop body. */
X }
X if (length == 0) {
X continue;
X }
X (void) strncpy(p, element, length);
X p += length;

X *p = ' ';
X p++;
X }

X if (p != result) {
X p[-1] = 0;
X } else {
X *p = 0;
X }

X return result;
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}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SetResult --
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_SetResult(interp, string, freeProc)
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 Tcl_FreeProc *freeProc; /* Gives information about the string:
X * TCL_STATIC, TCL_VOLATILE, or the address
X * of a Tcl_FreeProc such as free. */
X{
X register Interp *iPtr = (Interp *) interp;
X int length;
X Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
X char *oldResult = iPtr->result;
X
X iPtr->freeProc = freeProc;

X if (string == NULL) {

X iPtr->resultSpace[0] = 0;
X iPtr->result = iPtr->resultSpace;

X iPtr->freeProc = 0;
X } else if (freeProc == TCL_VOLATILE) {
X length = strlen(string);
X if (length > TCL_RESULT_SIZE) {
X iPtr->result = (char *) ckalloc((unsigned) length+1);
X iPtr->freeProc = (Tcl_FreeProc *) free;
X } else {

X iPtr->result = iPtr->resultSpace;

X iPtr->freeProc = 0;
X }
X strcpy(iPtr->result, string);
X } else {
X iPtr->result = string;
X }
X
X /*
X * If the old result was dynamically-allocated, free 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 (oldFreeProc != 0) {
X (*oldFreeProc)(oldResult);

X }
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_AppendResult --
X *
X * Append a variable number of strings onto the result already
X * present for an interpreter.

X *
X * Results:

X * None.

X *
X * Side effects:

X * The result in the interpreter given by the first argument
X * is extended by the strings given by the second and following
X * arguments (up to a terminating NULL argument).

X *
X *----------------------------------------------------------------------
X */
X

X /* VARARGS2 */
X#ifndef lint
Xvoid
XTcl_AppendResult(va_alist)
X#else
Xvoid

X /* VARARGS2 */ /* ARGSUSED */

XTcl_AppendResult(interp, p, va_alist)
X Tcl_Interp *interp; /* Interpreter whose result is to be
X * extended. */
X char *p; /* One or more strings to add to the
X * result, terminated with NULL. */

X#endif
X va_dcl
X{
X va_list argList;

X register Interp *iPtr;
X char *string;
X int newSpace;
X
X /*
X * First, scan through all the arguments to see how much space is
X * needed.
X */
X
X va_start(argList);
X iPtr = va_arg(argList, Interp *);
X newSpace = 0;
X while (1) {

X string = va_arg(argList, char *);

X if (string == NULL) {
X break;
X }
X newSpace += strlen(string);
X }
X va_end(argList);
X
X /*
X * If the append buffer isn't already setup and large enough
X * to hold the new data, set it up.
X */
X
X if ((iPtr->result != iPtr->appendResult)
X || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
X SetupAppendBuffer(iPtr, newSpace);
X }
X
X /*
X * Final step: go through all the argument strings again, copying
X * them into the buffer.
X */
X
X va_start(argList);
X (void) va_arg(argList, Tcl_Interp *);

X while (1) {
X string = va_arg(argList, char *);

X if (string == NULL) {
X break;
X }
X strcpy(iPtr->appendResult + iPtr->appendUsed, string);
X iPtr->appendUsed += strlen(string);
X }
X va_end(argList);

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_AppendElement --
X *
X * Convert a string to a valid Tcl list element and append it
X * to the current result (which is ostensibly a list).

X *
X * Results:

X * None.

X *
X * Side effects:

X * The result in the interpreter given by the first argument
X * is extended with a list element converted from string. If
X * the original result wasn't empty, then a blank is added before
X * the converted list element.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_AppendElement(interp, string, noSep)
X Tcl_Interp *interp; /* Interpreter whose result is to be
X * extended. */
X char *string; /* String to convert to list element and
X * add to result. */
X int noSep; /* If non-zero, then don't output a
X * space character before this element,
X * even if the element isn't the first
X * thing in the output buffer. */
X{
X register Interp *iPtr = (Interp *) interp;
X int size, flags;
X char *dst;
X
X /*
X * See how much space is needed, and grow the append buffer if
X * needed to accommodate the list element.
X */
X
X size = Tcl_ScanElement(string, &flags) + 1;
X if ((iPtr->result != iPtr->appendResult)
X || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
X SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
X }
X
X /*
X * Convert the string into a list element and copy it to the
X * buffer that's forming.
X */
X
X dst = iPtr->appendResult + iPtr->appendUsed;
X if (!noSep && (iPtr->appendUsed != 0)) {
X iPtr->appendUsed++;

X *dst = ' ';
X dst++;
X }

X iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * SetupAppendBuffer --
X *
X * This procedure makes sure that there is an append buffer
X * properly initialized for interp, and that it has at least
X * enough room to accommodate newSpace new bytes of information.

X *
X * Results:

X * None.

X *
X * Side effects:

X * None.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic void
XSetupAppendBuffer(iPtr, newSpace)
X register Interp *iPtr; /* Interpreter whose result is being set up. */
X int newSpace; /* Make sure that at least this many bytes
X * of new information may be added. */
X{
X int totalSpace;
X
X /*
X * Make the append buffer larger, if that's necessary, then
X * copy the current result into the append buffer and make the
X * append buffer the official Tcl result.
X */
X
X if (iPtr->result != iPtr->appendResult) {
X /*
X * If an oversized buffer was used recently, then free it up
X * so we go back to a smaller buffer. This avoids tying up
X * memory forever after a large operation.
X */
X
X if (iPtr->appendAvl > 500) {
X ckfree(iPtr->appendResult);

X iPtr->appendResult = NULL;
X iPtr->appendAvl = 0;
X }

X iPtr->appendUsed = strlen(iPtr->result);
X }
X totalSpace = newSpace + iPtr->appendUsed;
X if (totalSpace >= iPtr->appendAvl) {
X char *new;
X
X if (totalSpace < 100) {
X totalSpace = 200;
X } else {
X totalSpace *= 2;
X }
X new = (char *) ckalloc((unsigned) totalSpace);
X strcpy(new, iPtr->result);

X if (iPtr->appendResult != NULL) {
X ckfree(iPtr->appendResult);
X }

X iPtr->appendResult = new;
X iPtr->appendAvl = totalSpace;
X } else if (iPtr->result != iPtr->appendResult) {
X strcpy(iPtr->appendResult, iPtr->result);
X }
X Tcl_FreeResult(iPtr);
X iPtr->result = iPtr->appendResult;

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ResetResult --
X *
X * This procedure restores the result area for an interpreter
X * to its default initialized state, freeing up any memory that
X * may have been allocated for the result and clearing any
X * error information for the interpreter.

X *
X * Results:

X * None.

X *
X * Side effects:

X * None.

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
XTcl_ResetResult(interp)
X Tcl_Interp *interp; /* Interpreter for which to clear result. */
X{
X register Interp *iPtr = (Interp *) interp;
X

X Tcl_FreeResult(iPtr);
X iPtr->result = iPtr->resultSpace;
X iPtr->resultSpace[0] = 0;

X iPtr->flags &=
X ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SetErrorCode --
X *
X * This procedure is called to record machine-readable information
X * about an error that is about to be returned.

X *
X * Results:

X * None.

X *
X * Side effects:

X * The errorCode global variable is modified to hold all of the
X * arguments to this procedure, in a list form with each argument
X * becoming one element of the list. A flag is set internally
X * to remember that errorCode has been set, so the variable doesn't
X * get set automatically when the error is returned.

X *
X *----------------------------------------------------------------------
X */

X /* VARARGS2 */
X#ifndef lint
Xvoid
XTcl_SetErrorCode(va_alist)
X#else
Xvoid

X /* VARARGS2 */ /* ARGSUSED */

XTcl_SetErrorCode(interp, p, va_alist)
X Tcl_Interp *interp; /* Interpreter whose errorCode variable is
X * to be set. */
X char *p; /* One or more elements to add to errorCode,
X * terminated with NULL. */

X#endif
X va_dcl
X{
X va_list argList;

X char *string;
X int flags;
X Interp *iPtr;
X
X /*
X * Scan through the arguments one at a time, appending them to
X * $errorCode as list elements.
X */
X
X va_start(argList);
X iPtr = va_arg(argList, Interp *);
X flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;

X while (1) {
X string = va_arg(argList, char *);

X if (string == NULL) {
X break;
X }
X (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
X (char *) NULL, string, flags);

X flags |= TCL_APPEND_VALUE;
X }

X va_end(argList);

X iPtr->flags |= ERROR_CODE_SET;

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * TclGetListIndex --
X *
X * Parse a list index, which may be either an integer or the
X * value "end".

X *
X * Results:

X * The return value is either TCL_OK or TCL_ERROR. If it is
X * TCL_OK, then the index corresponding to string is left in
X * *indexPtr. If the return value is TCL_ERROR, then string
X * was bogus; an error message is returned in interp->result.
X * If a negative index is specified, it is rounded up to 0.
X * The index value may be larger than the size of the list
X * (this happens when "end" is specified).

X *
X * Side effects:

X * None.

X *
X *----------------------------------------------------------------------
X */
X

Xint
XTclGetListIndex(interp, string, indexPtr)
X Tcl_Interp *interp; /* Interpreter for error reporting. */
X char *string; /* String containing list index. */
X int *indexPtr; /* Where to store index. */
X{
X if (isdigit(*string) || (*string == '-')) {
X if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (*indexPtr < 0) {
X *indexPtr = 0;
X }
X } else if (strncmp(string, "end", strlen(string)) == 0) {
X *indexPtr = 1<<30;
X } else {
X Tcl_AppendResult(interp, "bad index \"", string,
X "\": must be integer or \"end\"", (char *) NULL);

X return TCL_ERROR;
X }
X return TCL_OK;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * TclCompileRegexp --
X *
X * Compile a regular expression into a form suitable for fast
X * matching. This procedure retains a small cache of pre-compiled
X * regular expressions in the interpreter, in order to avoid
X * compilation costs as much as possible.

X *
X * Results:

X * The return value is a pointer to the compiled form of string,
X * suitable for passing to regexec. If an error occurred while
X * compiling the pattern, then NULL is returned and an error
X * message is left in interp->result.

X *
X * Side effects:

X * The cache of compiled regexp's in interp will be modified to
X * hold information for string, if such information isn't already
X * present in the cache.

X *
X *----------------------------------------------------------------------
X */
X

Xregexp *
XTclCompileRegexp(interp, string)
X Tcl_Interp *interp; /* For use in error reporting. */
X char *string; /* String for which to produce
X * compiled regular expression. */
X{
X register Interp *iPtr = (Interp *) interp;
X int i, length;
X regexp *result;

X
X length = strlen(string);

X for (i = 0; i < NUM_REGEXPS; i++) {
X if ((length == iPtr->patLengths[i])
X && (strcmp(string, iPtr->patterns[i]) == 0)) {
X /*
X * Move the matched pattern to the first slot in the
X * cache and shift the other patterns down one position.
X */
X
X if (i != 0) {
X int j;
X char *cachedString;
X
X cachedString = iPtr->patterns[i];
X result = iPtr->regexps[i];
X for (j = i-1; j >= 0; j--) {
X iPtr->patterns[j+1] = iPtr->patterns[j];
X iPtr->patLengths[j+1] = iPtr->patLengths[j];
X iPtr->regexps[j+1] = iPtr->regexps[j];
X }
X iPtr->patterns[0] = cachedString;
X iPtr->patLengths[0] = length;
X iPtr->regexps[0] = result;
X }
X return iPtr->regexps[0];

X }
X }
X
X /*

X * No match in the cache. Compile the string and add it to the
X * cache.
X */

X
X tclRegexpError = NULL;

X result = regcomp(string);

X if (tclRegexpError != NULL) {
X Tcl_AppendResult(interp,

X "couldn't compile regular expression pattern: ",

X tclRegexpError, (char *) NULL);

X return NULL;
X }
X if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
X ckfree(iPtr->patterns[NUM_REGEXPS-1]);
X ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
X }
X for (i = NUM_REGEXPS - 2; i >= 0; i--) {
X iPtr->patterns[i+1] = iPtr->patterns[i];
X iPtr->patLengths[i+1] = iPtr->patLengths[i];
X iPtr->regexps[i+1] = iPtr->regexps[i];
X }
X iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
X strcpy(iPtr->patterns[0], string);
X iPtr->patLengths[0] = length;
X iPtr->regexps[0] = result;

X return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * regerror --
X *
X * This procedure is invoked by the Henry Spencer's regexp code
X * when an error occurs. It saves the error message so it can
X * be seen by the code that called Spencer's code.

X *
X * Results:

X * None.

X *
X * Side effects:

X * The value of "string" is saved in "tclRegexpError".

X *
X *----------------------------------------------------------------------
X */
X

Xvoid
Xregerror(string)
X char *string; /* Error message. */
X{
X tclRegexpError = string;
X}
END_OF_FILE
if test 36390 -ne `wc -c <'tcl6.1/tclUtil.c'`; then
echo shar: \"'tcl6.1/tclUtil.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUtil.c'
fi
echo shar: End of archive 29 $of 33$.
cp /dev/null ark29isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 5:59:42 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 98
Archive-name: tcl/part30
Environment: UNIX

# "End of archive 30 (of 33)."
# Contents: tcl6.1/tclUnixAZ.c
# Wrapped by karl@one on Tue Nov 12 19:44:32 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/tclUnixAZ.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/tclUnixAZ.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUnixAZ.c'\" $39407 characters$
sed "s/^X//" >'tcl6.1/tclUnixAZ.c' <<'END_OF_FILE'
X/*
X * tclUnixAZ.c --
X *
X * This file contains the top-level command procedures for
X * commands in the Tcl core that require UNIX facilities
X * such as files and process execution. Much of the code
X * in this file is based on earlier versions contributed
X * by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
X *
X * Copyright 1991 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 this copyright

X * notice appears 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: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.30 91/11/04 09:56:13 ouster Exp $ SPRITE (Berkeley)";

X#endif /* not lint */
X
X#include "tclInt.h"

X#include "tclUnix.h"
X
X/*
X * The variable below caches the name of the current working directory
X * in order to avoid repeated calls to getwd. The string is malloc-ed.
X * NULL means the cache needs to be refreshed.
X */
X
Xstatic char *currentDir = NULL;
X
X/*
X * Prototypes for local procedures defined in this file:
X */
X
Xstatic int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
X int numPids, int *pidPtr, int errorId));

X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CdCmd --
X *
X * This procedure is invoked to process the "cd" 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_CdCmd(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 *dirName;

X
X if (argc > 2) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " dirName\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X if (argc == 2) {

X dirName = argv[1];
X } else {
X dirName = "~";
X }
X dirName = Tcl_TildeSubst(interp, dirName);
X if (dirName == NULL) {
X return TCL_ERROR;
X }
X if (currentDir != NULL) {
X ckfree(currentDir);
X currentDir = NULL;
X }
X if (chdir(dirName) != 0) {
X Tcl_AppendResult(interp, "couldn't change working directory to \"",
X dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);

X return TCL_ERROR;
X }
X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_CloseCmd --
X *
X * This procedure is invoked to process the "close" 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_CloseCmd(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 OpenFile *filePtr;
X int result = TCL_OK;
X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X ((Interp *) interp)->filePtrArray[fileno(filePtr->f)] = NULL;
X
X /*
X * First close the file (in the case of a process pipeline, there may
X * be two files, one for the pipe at each end of the pipeline).
X */
X

X if (filePtr->f2 != NULL) {

X if (fclose(filePtr->f2) == EOF) {
X Tcl_AppendResult(interp, "error closing \"", argv[1],
X "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
X result = TCL_ERROR;
X }
X }
X if (fclose(filePtr->f) == EOF) {
X Tcl_AppendResult(interp, "error closing \"", argv[1],
X "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
X result = TCL_ERROR;
X }
X
X /*
X * If the file was a connection to a pipeline, clean up everything
X * associated with the child processes.
X */
X
X if (filePtr->numPids > 0) {
X if (CleanupChildren(interp, filePtr->numPids, filePtr->pidPtr,
X filePtr->errorId) != TCL_OK) {
X result = TCL_ERROR;
X }
X }
X
X ckfree((char *) filePtr);

X return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_EofCmd --
X *
X * This procedure is invoked to process the "eof" 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_EofCmd(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 OpenFile *filePtr;
X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (feof(filePtr->f)) {

X interp->result = "1";
X } else {

X interp->result = "0";
X }

X return TCL_OK;
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 int outputId; /* File id for output pipe. -1
X * means command overrode. */
X int errorId; /* File id for temporary file
X * containing error output. */
X int *pidPtr;
X int numPids, result;
X
X /*
X * See if the command is to be run in background; if so, create
X * the command, detach it, and return.
X */
X
X if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
X argc--;

X argv[argc] = NULL;

X numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
X (int *) NULL, (int *) NULL, (int *) NULL);
X if (numPids < 0) {
X return TCL_ERROR;
X }
X Tcl_DetachPids(numPids, pidPtr);
X ckfree((char *) pidPtr);

X return TCL_OK;
X }
X

X /*
X * Create the command's pipeline.
X */
X
X numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
X (int *) NULL, &outputId, &errorId);
X if (numPids < 0) {

X return TCL_ERROR;
X }
X

X /*
X * Read the child's output (if any) and put it into the result.
X */
X
X result = TCL_OK;
X if (outputId != -1) {
X while (1) {
X# define BUFFER_SIZE 1000
X char buffer[BUFFER_SIZE+1];
X int count;
X
X count = read(outputId, buffer, BUFFER_SIZE);
X
X if (count == 0) {
X break;
X }
X if (count < 0) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp,
X "error reading from output pipe: ",
X Tcl_UnixError(interp), (char *) NULL);
X result = TCL_ERROR;
X break;
X }
X buffer[count] = 0;
X Tcl_AppendResult(interp, buffer, (char *) NULL);
X }
X close(outputId);
X }
X
X if (CleanupChildren(interp, numPids, pidPtr, errorId) != TCL_OK) {
X result = TCL_ERROR;

X }
X return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ExitCmd --
X *
X * This procedure is invoked to process the "exit" 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_ExitCmd(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 value;
X
X if ((argc != 1) && (argc != 2)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ?returnCode?\"", (char *) NULL);
X return TCL_ERROR;
X }

X if (argc == 1) {

X exit(0);
X }
X if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
X return TCL_ERROR;
X }
X exit(value);
X return TCL_OK; /* Better not ever reach this! */

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, statOp;
X int mode = 0; /* Initialized only to prevent
X * compiler warning message. */
X struct stat statBuf;
X char *fileName, c;
X
X if (argc < 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " option name ?arg ...?\"", (char *) NULL);
X return TCL_ERROR;
X }

X c = argv[1][0];
X length = strlen(argv[1]);

X
X /*
X * First handle operations on the file name.
X */
X
X fileName = Tcl_TildeSubst(interp, argv[2]);
X if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
X if (argc != 3) {
X argv[1] = "dirname";
X not3Args:

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " ", argv[1], " name\"", (char *) NULL);
X return TCL_ERROR;
X }
X p = strrchr(fileName, '/');
X if (p == NULL) {
X interp->result = ".";
X } else if (p == fileName) {
X interp->result = "/";

X } else {
X *p = 0;

X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
X *p = '/';
X }
X return TCL_OK;
X } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)

X && (length >= 2)) {

X char *lastSlash;

X
X if (argc != 3) {

X argv[1] = "rootname";
X goto not3Args;
X }
X p = strrchr(fileName, '.');
X lastSlash = strrchr(fileName, '/');
X if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
X Tcl_SetResult(interp, fileName, TCL_VOLATILE);

X } else {
X *p = 0;

X Tcl_SetResult(interp, fileName, TCL_VOLATILE);
X *p = '.';
X }
X return TCL_OK;
X } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)

X && (length >= 3)) {

X char *lastSlash;

X
X if (argc != 3) {

X argv[1] = "extension";
X goto not3Args;
X }
X p = strrchr(fileName, '.');
X lastSlash = strrchr(fileName, '/');
X if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
X Tcl_SetResult(interp, p, TCL_VOLATILE);
X }
X return TCL_OK;
X } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)) {
X if (argc != 3) {
X argv[1] = "tail";
X goto not3Args;
X }
X p = strrchr(fileName, '/');

X if (p != NULL) {

X Tcl_SetResult(interp, p+1, TCL_VOLATILE);
X } else {
X Tcl_SetResult(interp, fileName, 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 (fileName == NULL) {
X return TCL_ERROR;
X }
X if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)

X && (length >= 2)) {
X if (argc != 3) {

X argv[1] = "readable";
X goto not3Args;
X }
X mode = R_OK;
X checkAccess:
X if (access(fileName, mode) == -1) {
X interp->result = "0";
X } else {
X interp->result = "1";
X }
X return TCL_OK;
X } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
X if (argc != 3) {
X argv[1] = "writable";
X goto not3Args;
X }
X mode = W_OK;
X goto checkAccess;
X } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)

X && (length >= 3)) {

X if (argc != 3) {

X argv[1] = "executable";
X goto not3Args;
X }
X mode = X_OK;
X goto checkAccess;
X } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)

X && (length >= 3)) {

X if (argc != 3) {

X argv[1] = "exists";
X goto not3Args;
X }
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 ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
X if (argc != 3) {
X argv[1] = "atime";
X goto not3Args;
X }
X if (stat(fileName, &statBuf) == -1) {
X goto badStat;
X }
X sprintf(interp->result, "%ld", statBuf.st_atime);
X return TCL_OK;
X } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)

X && (length >= 3)) {

X if (argc != 3) {

X argv[1] = "isdirectory";
X goto not3Args;
X }
X statOp = 2;
X } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)

X && (length >= 3)) {

X if (argc != 3) {

X argv[1] = "isfile";
X goto not3Args;
X }
X statOp = 1;
X } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
X if (argc != 3) {
X argv[1] = "mtime";
X goto not3Args;
X }
X if (stat(fileName, &statBuf) == -1) {
X goto badStat;
X }
X sprintf(interp->result, "%ld", statBuf.st_mtime);
X return TCL_OK;
X } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
X if (argc != 3) {
X argv[1] = "owned";
X goto not3Args;
X }
X statOp = 0;
X } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)

X && (length >= 2)) {
X if (argc != 3) {

X argv[1] = "size";
X goto not3Args;
X }
X if (stat(fileName, &statBuf) == -1) {
X goto badStat;
X }
X sprintf(interp->result, "%ld", statBuf.st_size);
X return TCL_OK;
X } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)

X && (length >= 2)) {

X char string[30];

X
X if (argc != 4) {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " stat name varName\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X if (stat(fileName, &statBuf) == -1) {
X badStat:
X Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X sprintf(string, "%d", statBuf.st_dev);
X if (Tcl_SetVar2(interp, argv[3], "dev", string, 0) == NULL) {
X setError:
X Tcl_AppendResult(interp,
X "couldn't store stat information in variable \"",
X argv[3], "\"", (char *) NULL);
X return TCL_ERROR;
X }
X sprintf(string, "%d", statBuf.st_ino);
X if (Tcl_SetVar2(interp, argv[3], "ino", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%d", statBuf.st_mode);
X if (Tcl_SetVar2(interp, argv[3], "mode", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%d", statBuf.st_nlink);
X if (Tcl_SetVar2(interp, argv[3], "nlink", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%d", statBuf.st_uid);
X if (Tcl_SetVar2(interp, argv[3], "uid", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%d", statBuf.st_gid);
X if (Tcl_SetVar2(interp, argv[3], "gid", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%ld", statBuf.st_size);
X if (Tcl_SetVar2(interp, argv[3], "size", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%ld", statBuf.st_atime);
X if (Tcl_SetVar2(interp, argv[3], "atime", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%ld", statBuf.st_mtime);
X if (Tcl_SetVar2(interp, argv[3], "mtime", string, 0) == NULL) {
X goto setError;
X }
X sprintf(string, "%ld", statBuf.st_ctime);
X if (Tcl_SetVar2(interp, argv[3], "ctime", string, 0) == NULL) {
X goto setError;
X }
X return TCL_OK;

X } else {
X Tcl_AppendResult(interp, "bad option \"", argv[1],

X "\": should be atime, dirname, executable, exists, ",
X "extension, isdirectory, isfile, mtime, owned, ",
X "readable, root, size, stat, tail, or writable",
X (char *) NULL);
X return TCL_ERROR;
X }
X if (stat(fileName, &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_FlushCmd --
X *
X * This procedure is invoked to process the "flush" 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_FlushCmd(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 OpenFile *filePtr;
X FILE *f;
X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (!filePtr->writable) {
X Tcl_AppendResult(interp, "\"", argv[1],
X "\" wasn't opened for writing", (char *) NULL);
X return TCL_ERROR;
X }
X f = filePtr->f2;
X if (f == NULL) {
X f = filePtr->f;
X }
X if (fflush(f) == EOF) {
X Tcl_AppendResult(interp, "error flushing \"", argv[1],

X "\": ", Tcl_UnixError(interp), (char *) NULL);

X clearerr(f);

X return TCL_ERROR;
X }
X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_GetsCmd --
X *
X * This procedure is invoked to process the "gets" 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_GetsCmd(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# define BUF_SIZE 200
X char buffer[BUF_SIZE+1];
X int totalCount, done, flags;
X OpenFile *filePtr;
X register FILE *f;

X
X if ((argc != 2) && (argc != 3)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId ?varName?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (!filePtr->readable) {
X Tcl_AppendResult(interp, "\"", argv[1],
X "\" wasn't opened for reading", (char *) NULL);

X return TCL_ERROR;
X }
X

X /*
X * We can't predict how large a line will be, so read it in
X * pieces, appending to the current result or to a variable.
X */
X
X totalCount = 0;
X done = 0;
X flags = 0;
X f = filePtr->f;
X while (!done) {
X register int c, count;

X register char *p;
X

X for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
X c = getc(f);
X if (c == EOF) {
X if (ferror(filePtr->f)) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "error reading \"", argv[1],

X "\": ", Tcl_UnixError(interp), (char *) NULL);

X clearerr(filePtr->f);
X return TCL_ERROR;
X } else if (feof(filePtr->f)) {
X if ((totalCount == 0) && (count == 0)) {
X totalCount = -1;
X }
X done = 1;
X break;
X }
X }
X if (c == '\n') {
X done = 1;
X break;
X }
X *p = c;

X }
X *p = 0;

X if (argc == 2) {

X Tcl_AppendResult(interp, buffer, (char *) NULL);
X } else {
X Tcl_SetVar(interp, argv[2], buffer, flags);

X flags = TCL_APPEND_VALUE;
X }

X totalCount += count;
X }
X
X if (argc == 3) {
X sprintf(interp->result, "%d", totalCount);

X }
X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_OpenCmd --
X *
X * This procedure is invoked to process the "open" 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_OpenCmd(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 Interp *iPtr = (Interp *) interp;
X int pipeline, fd;
X char *access;
X register OpenFile *filePtr;

X
X if (argc == 2) {

X access = "r";
X } else if (argc == 3) {
X access = argv[2];

X } else {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " filename ?access?\"", (char *) NULL);

X return TCL_ERROR;
X }
X

X filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));

X filePtr->f = NULL;

X filePtr->f2 = NULL;
X filePtr->readable = 0;

X filePtr->writable = 0;
X filePtr->numPids = 0;
X filePtr->pidPtr = NULL;
X filePtr->errorId = -1;

X
X /*
X * Verify the requested form of access.
X */
X
X pipeline = 0;
X if (argv[1][0] == '|') {
X pipeline = 1;
X }
X switch (access[0]) {
X case 'r':
X filePtr->readable = 1;
X break;
X case 'w':
X filePtr->writable = 1;
X break;
X case 'a':

X filePtr->writable = 1;

X break;
X default:
X badAccess:
X Tcl_AppendResult(interp, "illegal access mode \"", access,
X "\"", (char *) NULL);
X goto error;
X }
X if (access[1] == '+') {
X filePtr->readable = filePtr->writable = 1;
X if (access[2] != 0) {
X goto badAccess;
X }
X } else if (access[1] != 0) {
X goto badAccess;
X }
X
X /*
X * Open the file or create a process pipeline.
X */
X
X if (!pipeline) {
X char *fileName = argv[1];
X
X if (fileName[0] == '~') {

X fileName = Tcl_TildeSubst(interp, fileName);
X if (fileName == NULL) {

X goto error;
X }
X }

X filePtr->f = fopen(fileName, access);
X if (filePtr->f == NULL) {
X Tcl_AppendResult(interp, "couldn't open \"", argv[1],

X "\": ", Tcl_UnixError(interp), (char *) NULL);

X goto error;
X }
X } else {

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

X }
X }
X
X /*

X * Enter this new OpenFile structure in the table for the
X * interpreter. May have to expand the table to do this.
X */
X
X fd = fileno(filePtr->f);
X TclMakeFileTable(iPtr, fd);
X if (iPtr->filePtrArray[fd] != NULL) {
X panic("Tcl_OpenCmd found file already open");
X }
X iPtr->filePtrArray[fd] = filePtr;
X sprintf(interp->result, "file%d", fd);
X return TCL_OK;
X
X error:
X if (filePtr->f != NULL) {
X fclose(filePtr->f);
X }

X if (filePtr->f2 != NULL) {
X fclose(filePtr->f2);
X }
X if (filePtr->numPids > 0) {
X Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
X ckfree((char *) filePtr->pidPtr);
X }

X if (filePtr->errorId != -1) {
X close(filePtr->errorId);

X }
X ckfree((char *) filePtr);

X return TCL_ERROR;
X}
X

X/*
X *----------------------------------------------------------------------
X *

X * Tcl_PwdCmd --
X *
X * This procedure is invoked to process the "pwd" 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_PwdCmd(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 buffer[MAXPATHLEN+1];
X
X if (argc != 1) {

X Tcl_AppendResult(interp, "wrong # args: should be \"",

X argv[0], "\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (currentDir == NULL) {
X#if TCL_GETWD
X if (getwd(buffer) == NULL) {
X Tcl_AppendResult(interp, "error getting working directory name: ",
X buffer, (char *) NULL);
X return TCL_ERROR;
X }
X#else
X if (getcwd(buffer, MAXPATHLEN) == NULL) {

X if (errno == ERANGE) {

X interp->result = "working directory name is too long";
X } else {
X Tcl_AppendResult(interp,
X "error getting working directory name: ",
X Tcl_UnixError(interp), (char *) NULL);

X }
X return TCL_ERROR;
X }

X#endif
X currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
X strcpy(currentDir, buffer);
X }
X interp->result = currentDir;

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_PutsCmd --
X *
X * This procedure is invoked to process the "puts" 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_PutsCmd(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 OpenFile *filePtr;
X FILE *f;
X

X if (argc == 4) {

X if (strncmp(argv[3], "nonewline", strlen(argv[3])) != 0) {
X Tcl_AppendResult(interp, "bad argument \"", argv[3],
X "\": should be \"nonewline\"", (char *) NULL);
X return TCL_ERROR;
X }
X } else if (argc != 3) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId string ?nonewline?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (!filePtr->writable) {
X Tcl_AppendResult(interp, "\"", argv[1],
X "\" wasn't opened for writing", (char *) NULL);

X return TCL_ERROR;
X }
X

X f = filePtr->f2;
X if (f == NULL) {
X f = filePtr->f;
X }
X fputs(argv[2], f);
X if (argc == 3) {
X fputc('\n', f);
X }
X if (ferror(f)) {
X Tcl_AppendResult(interp, "error writing \"", argv[1],

X "\": ", Tcl_UnixError(interp), (char *) NULL);

X clearerr(f);

X return TCL_ERROR;
X }
X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_ReadCmd --
X *
X * This procedure is invoked to process the "read" 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_ReadCmd(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 OpenFile *filePtr;
X int numBytes, count;
X struct stat statBuf;
X int newline;

X
X if ((argc != 2) && (argc != 3)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId ?numBytes|nonewline?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (!filePtr->readable) {
X Tcl_AppendResult(interp, "\"", argv[1],
X "\" wasn't opened for reading", (char *) NULL);

X return TCL_ERROR;
X }
X

X /*
X * Compute how many bytes to read, and see whether the final
X * newline should be dropped.
X */
X
X newline = 1;
X if ((argc > 2) && isdigit(argv[2][0])) {
X if (Tcl_GetInt(interp, argv[2], &numBytes) != TCL_OK) {
X return TCL_ERROR;
X }
X } else {
X
X /*
X * Compute how many bytes are left in the file. Try to read
X * one more byte than this, just to force the eof condition
X * to be seen.
X */
X
X if (fstat(fileno(filePtr->f), &statBuf) < 0) {
X Tcl_AppendResult(interp,
X "couldn't compute size of \"", argv[1],
X "\": ", Tcl_UnixError(interp), (char *) NULL);
X return TCL_ERROR;
X }
X numBytes = statBuf.st_size - ftell(filePtr->f) + 1;
X if (argc > 2) {
X if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
X newline = 0;
X } else {
X Tcl_AppendResult(interp, "bad argument \"", argv[2],
X "\": should be \"nonewline\"", (char *) NULL);

X return TCL_ERROR;
X }
X }

X }
X
X /*
X * Read the bytes into a dynamically-allocated array, and
X * return it as result.
X */
X
X interp->result = (char *) ckalloc((unsigned) numBytes+1);
X interp->freeProc = (Tcl_FreeProc *) free;
X count = fread(interp->result, 1, numBytes, filePtr->f);
X if (ferror(filePtr->f)) {
X Tcl_ResetResult(interp);
X Tcl_AppendResult(interp, "error reading \"", argv[1],

X "\": ", Tcl_UnixError(interp), (char *) NULL);

X clearerr(filePtr->f);
X return TCL_ERROR;
X }
X if ((newline == 0) && (interp->result[count-1] == '\n')) {
X interp->result[count-1] = 0;
X } else {
X interp->result[count] = 0;
X }

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_SeekCmd --
X *
X * This procedure is invoked to process the "seek" 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_SeekCmd(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 OpenFile *filePtr;
X int offset, mode;

X
X if ((argc != 3) && (argc != 4)) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId offset ?origin?\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
X return TCL_ERROR;
X }
X mode = SEEK_SET;

X if (argc == 4) {

X int length;
X char c;

X
X length = strlen(argv[3]);
X c = argv[3][0];
X if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
X mode = SEEK_SET;
X } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
X mode = SEEK_CUR;
X } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
X mode = SEEK_END;
X } else {
X Tcl_AppendResult(interp, "bad origin \"", argv[3],
X "\": should be start, current, or end", (char *) NULL);

X return TCL_ERROR;
X }
X }

X if (fseek(filePtr->f, offset, mode) == -1) {
X Tcl_AppendResult(interp, "error during seek: ",

X Tcl_UnixError(interp), (char *) NULL);

X clearerr(filePtr->f);

X return TCL_ERROR;
X }
X

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 if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileName\"", (char *) NULL);
X return TCL_ERROR;
X }
X return Tcl_EvalFile(interp, argv[1]);

X}
X
X/*
X *----------------------------------------------------------------------
X *

X * Tcl_TellCmd --
X *
X * This procedure is invoked to process the "tell" 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_TellCmd(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 OpenFile *filePtr;
X
X if (argc != 2) {

X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " fileId\"", (char *) NULL);
X return TCL_ERROR;
X }
X if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
X return TCL_ERROR;
X }
X sprintf(interp->result, "%d", ftell(filePtr->f));

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 double timePer;
X#if TCL_GETTOD
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
X if (argc == 2) {

X count = 1;

X } else if (argc == 3) {

X if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
X return TCL_ERROR;
X }

X } else {
X Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

X " command ?count?\"", (char *) NULL);
X return TCL_ERROR;
X }
X#if TCL_GETTOD
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, "\n (\"time\" body line %d)",

X interp->errorLine);
X Tcl_AddErrorInfo(interp, msg);

X }
X return result;
X }
X }

X#if TCL_GETTOD
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 timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
X#endif
X Tcl_ResetResult(interp);
X sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);

X return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *

X * CleanupChildren --
X *
X * This is a utility procedure used to wait for child processes
X * to exit, record information about abnormal exits, and then
X * collect any stderr output generated by them.

X *
X * Results:

X * The return value is a standard Tcl result. If anything at
X * weird happened with the child processes, TCL_ERROR is returned
X * and a message is left in interp->result.

X *
X * Side effects:

X * If the last character of interp->result is a newline, then it
X * is removed. File errorId gets closed, and pidPtr is freed
X * back to the storage allocator.

X *
X *----------------------------------------------------------------------
X */
X

Xstatic int
XCleanupChildren(interp, numPids, pidPtr, errorId)
X Tcl_Interp *interp; /* Used for error messages. */
X int numPids; /* Number of entries in pidPtr array. */
X int *pidPtr; /* Array of process ids of children. */
X int errorId; /* File descriptor index for file containing
X * stderr output from pipeline. -1 means
X * there isn't any stderr output. */
X{
X int result = TCL_OK;
X int i, pid, length;
X WAIT_STATUS_TYPE waitStatus;
X

X for (i = 0; i < numPids; i++) {

X pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);

X if (pid == -1) {

X Tcl_AppendResult(interp, "error waiting for process to exit: ",

X Tcl_UnixError(interp), (char *) NULL);

X continue;
X }
X
X /*
X * Create error messages for unusual process exits. An
X * extra newline gets appended to each error message, but
X * it gets removed below (in the same fashion that an
X * extra newline in the command's output is removed).
X */
X
X if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
X char msg1[20], msg2[20];
X
X result = TCL_ERROR;
X sprintf(msg1, "%d", pid);
X if (WIFEXITED(waitStatus)) {
X sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
X Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
X (char *) NULL);
X } else if (WIFSIGNALED(waitStatus)) {
X char *p;
X
X p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
X Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
X Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
X (char *) NULL);
X Tcl_AppendResult(interp, "child killed: ", p, "\n",
X (char *) NULL);
X } else if (WIFSTOPPED(waitStatus)) {
X char *p;
X
X p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
X Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
X Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
X Tcl_AppendResult(interp, "child suspended: ", p, "\n",
X (char *) NULL);
X } else {
X Tcl_AppendResult(interp,
X "child wait status didn't make sense\n",

X (char *) NULL);
X }

X }
X }
X ckfree((char *) pidPtr);
X
X /*
X * Read the standard error file. If there's anything there,
X * then return an error and add the file's contents to the result
X * string.
X */
X
X if (errorId >= 0) {
X while (1) {
X# define BUFFER_SIZE 1000
X char buffer[BUFFER_SIZE+1];
X int count;
X
X count = read(errorId, buffer, BUFFER_SIZE);
X
X if (count == 0) {
X break;
X }
X if (count < 0) {
X Tcl_AppendResult(interp,
X "error reading stderr output file: ",
X Tcl_UnixError(interp), (char *) NULL);
X break;
X }
X buffer[count] = 0;
X Tcl_AppendResult(interp, buffer, (char *) NULL);
X }
X close(errorId);
X }
X
X /*
X * If the last character of interp->result is a newline, then remove
X * the newline character (the newline would just confuse things).
X */
X
X length = strlen(interp->result);
X if ((length > 0) && (interp->result[length-1] == '\n')) {
X interp->result[length-1] = '\0';
X }
X

X return result;
X}
END_OF_FILE

if test 39407 -ne `wc -c <'tcl6.1/tclUnixAZ.c'`; then
echo shar: \"'tcl6.1/tclUnixAZ.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUnixAZ.c'
fi
echo shar: End of archive 30 $of 33$.
cp /dev/null ark30isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 6:01:00 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 99
Archive-name: tcl/part31
Environment: UNIX

# "End of archive 31 (of 33)."
# Contents: tcl6.1/doc/usenix.text
# Wrapped by karl@one on Tue Nov 12 19:44:33 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/usenix.text' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/usenix.text'\"
else
echo shar: Extracting \"'tcl6.1/doc/usenix.text'\" $41391 characters$
sed "s/^X//" >'tcl6.1/doc/usenix.text' <<'END_OF_FILE'
XTcl: An Embeddable Command Language
XJohn K. Ousterhout
XComputer Science Division
XElectrical Engineering and Computer Sciences

XUniversity of California at Berkeley

XBerkeley, CA 94720
Xou...@sprite.berkeley.edu
X
XABSTRACT
X
XTcl is an interpreter for a tool command language. It consists of a library
Xpackage that is embedded in tools (such as editors, debuggers, etc.) as the
Xbasic command interpreter. Tcl provides (a) a parser for a simple textual
Xcommand language, (b) a collection of built-in utility commands, and (c)
Xa C interface that tools use to augment the built-in commands with
Xtool-specific commands. Tcl is particularly attractive when integrated with
Xthe widget library of a window system: it increases the programmability of
Xthe widgets by providing mechanisms for variables, procedures, expressions,
Xetc; it allows users to program both the appearance and the actions of
Xwidgets; and it offers a simple but powerful communication mechanism between
Xinteractive programs.
X
XThe work described here was supported in part by the National Science
XFoundation under Grant ECS-8351961.
X
X
X1. Introduction
X
XTcl stands for ``tool command language''. It consists of a library package
Xthat programs can use as the basis for their command languages. The
Xdevelopment of Tcl was motivated by two observations. The first observation
Xis that a general-purpose programmable command language amplifies the power
Xof a tool by allowing users to write programs in the command language in
Xorder to extend the tool's built-in facilities. Among the best-known
Xexamples of powerful command languages are those of the UNIX shells [5]
Xand the Emacs editor [8]. In each case a computing environment of unusual
Xpower has arisen, in large part because of the availability of a pro-
Xgrammable command language.
X
XThe second motivating observation is that the number of interactive
Xapplications is increasing. In the timesharing environments of the late
X1970's and early 1980's almost all programs were batch-oriented. They
Xwere typically invoked using an interactive command shell. Besides the
Xshell, only a few other programs needed to be interactive, such as editors
Xand mailers. In contrast, the personal workstations used today, with their
Xraster displays and mice, encourage a different system structure where a
Xlarge number of programs are interactive and the most common style of
Xinteraction is to manipulate individual applications directly with a mouse.
XFurthermore, the large displays available today make it possible for many
Xinteractive applications to be active at once, whereas this was not practical
Xwith the smaller screens of ten years ago.
X
XUnfortunately, few of today's interactive applications have the power of the
Xshell or Emacs command languages. Where good command languages exist, they
Xtend to be tied to specific programs. Each new interactive application
Xrequires a new command language to be developed. In most cases application
Xprogrammers do not have the time or inclination to implement a general-purpose
Xfacility (particularly if the application itself is simple), so the resulting
Xcommand languages tend to have insufficient power and clumsy syntax.
X
XTcl is an application-independent command language. It exists as a
XC library package that can be used in many different programs. The
XTcl library provides a parser for a simple but fully programmable command
Xlanguage. The library also implements a collection of built-in commands
Xthat provide general-purpose programming constructs such as variables,
Xlists, expressions, conditionals, looping, and procedures. Individual
Xapplication programs extend the basic Tcl language with application-specific
Xcommands. The Tcl library also provides a set of utility routines to simplify
Xthe implementation of tool-specific commands.
X
XI believe that Tcl is particularly useful in a windowing environment, and that
Xit provides two advantages. First, it can be used as a general-purpose
Xmechanism for programming the interfaces of applications. If a tool is based
Xon Tcl, then it should be relatively easy to modify the application's user
Xinterface and to extend the interface with new commands. Second, and more
Ximportant, Tcl provides a uniform framework for communication between tools.
XIf used uniformly in all tools, Tcl will make it possible for tools to work
Xtogether more gracefully than is possible today.
X
XThe rest of this paper is organized as follows. Section 2 describes the
XTcl language as seen by users. Section 3 discusses how Tcl is used in
Xapplications, including the C-language interface between application
Xprograms and the Tcl library. Section 4 describes how Tcl can be used
Xin a windowing environment to customize interface actions and appearances.
XSection 5 shows how Tcl can be used as a vehicle for communication between
Xapplications, and why this is important. Section 6 presents the status
Xof the Tcl implementation and some preliminary performance measurements.
XSection 7 compares Tcl to Lisp, Emacs, and NeWS, and Section 8 concludes
Xthe paper.
X
X2. The Tcl Language
X
XIn a sense, the syntax of the Tcl language is unimportant: any programming
Xlanguage, whether it is C [6], Forth [4], Lisp [1], or Postscript [2],
Xcould provide many of the same programmability and communication advantages
Xas Tcl. This suggests that the best implementation approach is to borrow
Xan existing language and concentrate on providing a convenient framework for
Xthe use of that language. However, the environment for an embeddable command
Xlanguage presents an unusual set of constraints on the language, which are
Xdescribed below. I eventually decided that a new language designed from
Xscratch could probably meet the constraints with less implementation effort
Xthan any existing language.
X
XTcl is unusual because it presents two different interfaces: a textual
Xinterface to users who issue Tcl commands, and a procedural interface to the
Xapplications in which it is embedded. Each of these interfaces must be
Xsimple, powerful, and efficient. There were four major factors in the
Xlanguage design:
X
X[1] The language is for commands.
X
XAlmost all Tcl ``programs'' will be short, many only one line long. Most
Xprograms will be typed in, executed once or perhaps a few times, and then
Xdiscarded. This suggests that the language should have a simple syntax so
Xthat it is easy to type commands. Most existing programming languages have
Xcomplex syntax; the syntax is helpful when writing long programs but would
Xbe clumsy if used for a command language.
X
X[2] The language must be programmable.
X
XIt should contain general programming constructs such as variables,
Xprocedures, conditionals, and loops, so that users can extend the built-in
Xcommand set by writing Tcl procedures. Extensibility also argues for
Xa simple syntax: this makes it easier for Tcl programs to generate other
XTcl programs.
X
X[3] The language must permit a simple and efficient interpreter.
X
XFor the Tcl library to be included in many small programs, particularly
Xon machines without shared-library facilities, the interpreter must not
Xoccupy much memory. The mechanism for interpreting Tcl commands must be
Xfast enough to be usable for events that occur hundreds of times a second,
Xsuch as mouse motion.
X
X[4] The language must permit a simple interface to C applications.
X
XIt must be easy for C applications to invoke the interpreter and easy
Xfor them to extend the built-in commands with application-specific
Xcommands. This factor was one of the reasons why I decided not to
Xuse Lisp as the command language: Lisp's basic data types and storage
Xmanagement mechanisms are so different than those of C that it would
Xbe difficult to build a clean and simple interface between them.
X
XFor Tcl I used a data type (string) that is natural to C.
X
X2.1. Tcl Language Syntax
X
XTcl's basic syntax is similar to that of the UNIX shells: a command consists
Xof one or more fields separated spaces or tabs. The first field is the name
Xof a command, which may be either a built-in command, an application-specific
Xcommand, or a procedure consisting of a sequence of Tcl commands. Fields
Xafter the first one are passed to the command as arguments. Newline
Xcharacters are used as command separators, just as in the UNIX shells, and
Xsemi-colons may be used to separate commands on the same line. Unlike the
XUNIX shells, each Tcl command returns a string result, or the empty string
Xif a return value isn't appropriate.
X
XThere are four additional syntactic constructs in Tcl, which give the language
Xa Lisp-like flavor. Curly braces are used to group complex arguments; they
Xact as nestable quote characters. If the first character of an argument is a
Xopen brace, then the argument is not terminated by white space. Instead, it
Xis terminated by the matching close brace. The argument passed to the command
Xconsists of everything between the braces, with the enclosing braces stripped
Xoff. For example, the command
X
X set a {dog cat {horse cow mule} bear}
X
Xwill receive two arguments: ``a'' and ``dog cat {horse cow mule} bear''.
XThis particular command will set the variable
X a
Xto a string equal to the second argument. If an argument is enclosed
Xin braces, then none of the other substitutions described below is made
Xon the argument. One of the most common uses of braces is to specify a
XTcl subprogram as an argument to a Tcl command.
X
XThe second syntactic construct in Tcl is square brackets, which are used to
Xinvoke command substitution. If an open bracket appears in an argument, then
Xeverything from the open bracket up to the matching close bracket is treated
Xas a command and executed recursively by the Tcl interpreter. The result of
Xthe command is then substituted into the argument in place of the bracketed
Xstring. For example, consider the command
X
X set a [format {Santa Claus is %s years old} 99]
X
XThe format command does printf-like formatting and returns the string
X``Santa Claus is 99 years old'', which is then passed to set and assigned
Xto variable a.
X
XThe third syntactic construct is the dollar sign, which is used for variable
Xsubstitution. If it appears in an argument then the following characters are
Xtreated as a variable name; the contents of the variable are substituted into
Xthe argument in place of the dollar sign and name. For example, the commands
X
Xset b 99
Xset a [format {Santa Claus is %s years old} $b]
X
Xresult in the same final value for a as the single command in the previous
Xparagraph. Variable substitution isn't strictly necessary since there are
Xother ways to achieve the same effect, but it reduces typing.
X
XThe last syntactic construct is the backslash character, which may be used
Xto insert special characters into arguments, such as curly braces or
Xnon-printing characters.
X
X2.2. Data Types
X
XThere is only one type of data in Tcl: strings. All commands, arguments
Xto commands, results returned by commands, and variable values are ASCII
Xstrings. The use of strings throughout Tcl makes it easy to pass information
Xback and forth between Tcl library procedures and C code in the enclosing
Xapplication. It also makes it easier to pass Tcl-related information back
Xand forth between machines of different types.
X
XAlthough everything in Tcl is a string, many commands expect their string
Xarguments to have particular formats. There are three particularly common
Xformats for strings: lists, expressions, and commands. A list is just a
Xstring containing one or more fields separated by white space, similar to
Xa command. Curly braces may be used to enclose complex list elements; these
Xcomplex list elements are often lists in their own right, as in Lisp. For
Xexample, the string
X
X dog cat {horse cow mule} bear
X
Xis a list with four elements, the third of which is a list with three
Xelements. Tcl provides commands for a number of list-manipulation operations,
Xsuch as creating lists, extracting elements, and computing list lengths.
X
XThe second common form for a string is a numeric expression. Tcl
Xexpressions have the same operators and precedence as expressions in C.
XThe "expr" Tcl command evaluates a string as an expression and returns the
Xresult (as a string, of course). For example, the command
X
Xexpr {($a < $b) || ($c != 0)}
X
Xreturns ``0'' if the numeric value of variable a is less than that of
Xvariable b, or if variable c is not zero; otherwise it returns
X``0''. Several other commands, such as "if" and "for", expect one or more
Xof their arguments to be expressions.
X
XThe third common interpretation of strings is as commands (or sequences of
Xcommands). Arguments of this form are used in Tcl commands that implement
Xcontrol structures. For example, consider the following command:
X
Xif {$a < $b} {
X set tmp $a
X set a $b
X set b $tmp
X}
X
XThe "if" command receives two arguments here, each of which is delimited
Xby curly braces. "If" is a built-in command that evaluates its first
Xargument as an expression; if the result is non-zero, "if" executes its
Xsecond argument as a Tcl command. This particular command swaps the
Xvalues of the variables "a" and "b" if "a" is less than "b".
X
XTcl also allows users to define command procedures written in the Tcl
Xlanguage. I will refer to these procedures as tclproc's, in order to
Xdistinguish them from other procedures written in C. The "proc" built-in
Xcommand is used to create a tclproc. For example, here is a Tcl command
Xthat defines a recursive factorial procedure:
X
Xproc fac x {
X if {$x == 1} {return 1}
X return [expr {$x * [fac [expr $x-1]]}]
X}
X
XThe "proc" command takes three arguments: a name for the new tclproc, a
Xlist of variable names (in this case the list has only a single element,
X"x"), and a Tcl command that comprises the body of the tclproc. Once
Xthis proc command has been executed, "fac" may be invoked just like any
Xother Tcl command. For example
X
X fac 4
X
Xwill return the string ``24''.
X
XFigure 1 lists all of the built-in Tcl commands in groups. In addition to
Xthe commands already mentioned, Tcl provides commands for manipulating
Xstrings (comparison, matching, and printf/scanf-like operations), commands
Xfor manipulating files and file names, and a command to fork a subprocess
Xand return the subprocess's standard output as result. The built-in Tcl
Xcommands provide a simple but complete programming language. The built-in
Xfacilities may be extended in three ways: by writing tclprocs; by invoking
Xother programs as subprocesses; or by defining new commands with C
Xprocedures as described in the next section.
X
X3. Embedding Tcl in Applications
X
XAlthough the built-in Tcl commands could conceivably be used as a
Xstand-alone programming system, Tcl is really intended to be embedded
Xin application programs. I have built several application programs using
XTcl, one of which is a mouse-based editor for X called "mx". In the rest
Xof the paper I will use examples from mx to illustrate how Tcl interacts
Xwith its enclosing application.
X
XAn application using Tcl extends the built-in commands with a few
Xadditional commands related to that particular application. For
Xexample, a clock program might provide additional commands to control
Xhow the clock is displayed and to set alarms; the mx editor provides
Xadditional commands to read a file from disk, display it in a window,
Xselect and modify ranges of bytes, and write the modified file back to
Xdisk. An application programmer need only write the application-specific
Xcommands; the built-in commands provide programmability and extensibility
X``for free''. To users, the application-specific commands appear the same
Xas the built-in commands.
X
XFigure 2 shows the relationship between Tcl and the rest of an application.
XTcl is a C library package that is linked with the application. The Tcl
Xlibrary includes a parser for the Tcl language, procedures to execute the
Xbuilt-in commands, and a set of utility procedures for things like expression
Xevaluation and list management. The parser includes an extension interface
Xthat may be used to extend the language's command set.
X
XTo use Tcl, an application first creates an object called an "interpreter",
Xusing the following library procedure:
X
X Tcl_Interp *Tcl_CreateInterp()
X
XAn interpreter consists of a set of commands, a set of variable bindings,
Xand a command execution state. It is the basic unit manipulated by most
Xof the Tcl library procedures.
X
XSimple applications will use only a single interpreter, while more complex
Xapplications may use multiple interpreters for different purposes. For
Xexample, mx uses one interpreter for each window on the screen.
X
XThe Tcl library provides a parser for the Tcl language, a set of built-in
Xcommands, and several utility procedures. The application provides
Xapplication-specific commands plus procedures to collect commands for
Xexecution. The commands are parsed by Tcl and then passed to relevant
Xcommand procedures (either in Tcl or in the application) for execution.
X
XOnce an application has created an interpreter, it calls the
XTcl_CreateCommand procedure to extend the interpreter with
Xapplication-specific commands:
X
Xtypedef int Tcl_CmdProc((ClientData) clientData, Tcl_Interp *interp,
X int argc, char *argv[]);
X
XTcl_CreateCommand(Tcl_Interp *interp, char *name, Tcl_CmdProc proc,
X ClientData clientData)
X
XEach call to Tcl_CreateCommand associates a particular command name
X(name) with a procedure that implements that command (proc) and an
Xarbitrary single-word value to pass to that procedure (clientData).
X
XAfter creating application-specific commands, the application enters
Xa main loop that collects commands and passes them to the Tcl_Eval
Xprocedure for execution:
X
X int Tcl_Eval(Tcl_Interp *interp, char *cmd)
X
XIn the simplest form, an application might simply read commands from the
Xterminal or from a file. In the mx editor Tcl commands are associated
Xwith events such as keystrokes, mouse buttons, or menu activations; each
Xtime an event occurs, the corresponding Tcl command is passed to Tcl_Eval.
X
XThe Tcl_Eval procedure parses its cmd argument into fields, looks up the
Xcommand name in the table of those associated with the interpreter, and
Xinvokes the command procedure associated with that command. All command
Xprocedures, whether built-in or application-specific, are called in the
Xsame way, as described in the typedef for Tcl_CmdProc above.
XA command procedure is passed an array of strings describing the command's
Xarguments (argc and argv) plus the clientData value that was associated
Xwith the command when it was created. ClientData is typically a pointer
Xto an application-specific structure containing information needed to
Xexecute the command. For example, in mx the clientData argument points
Xto a per-window data structure describing the file being edited and the
Xwindow it is displayed in.
X
XControl mechanisms like "if" and "for" are implemented with recursive
Xcalls to Tcl_Eval. For example, the command procedure for the "if"
Xcommand evaluates its first argument as an expression; if the result
Xis non-zero, then it calls Tcl_Eval recursively to execute its second
Xargument as a Tcl command. During the execution of that command, Tcl_Eval
Xmay be called recursively again, and so on. Tcl_Eval also calls itself
Xrecursively to execute bracketed commands that appear in arguments.
X
X
XEven tclprocs such as fac use this same basic mechanism.
XWhen the "proc" command is invoked to create "fac", the proc command
Xprocedure creates a new command by calling Tcl_CreateCommand as
Xillustrated in Figure 3. The new command has the name "fac". Its
Xcommand procedure ("proc" in the call to Tcl_CreateCommand) is a
Xspecial Tcl library procedure called "InterpProc", and its clientData
Xis a pointer to a structure describing the tclproc. This structure
Xcontains, among other things, a copy of the body of the tclproc (the
Xthird argument to the proc command). When the fac command is invoked,
XTcl_Eval calls InterpProc, which in turn calls Tcl_Eval to execute the
Xbody of the tclproc. There is some additional code required to associate
Xthe argument of the fac command (which is passed to InterpProc in its argv
Xarray) with the "x" variable used inside fac's body, and to support variables
Xwith local scope, but much of the mechanism for tclprocs is the same as that
Xfor any other Tcl command.
X
XThe creation and execution of a tclproc (a procedure written in Tcl):
X(a) the proc command is invoked, e.g. to create the fac procedure; (b)
Xthe Tcl parser invokes the command procedure associated with proc; (c)
Xthe proc command procedure creates a data structure to hold the Tcl
Xcommand that is fac's body; (d) fac is registered as a new Tcl command,
Xwith InterpProc as its command procedure; (e) fac is invoked as a Tcl
Xcommand; (f) the Tcl parser invokes InterpProc as the command procedure
Xfor fac; (g) InterpProc retrieves the body of fac from the data structure;
Xand (h) the Tcl commands in fac's body are passed back to the Tcl parser
Xfor execution.
X
XA Tcl command procedure returns two results to Tcl_Eval: an integer return
Xcode and a string. The return code is returned as the procedure's result,
Xand the string is stored in the interpreter, from which it can be retrieved
Xlater. Tcl_Eval returns the same code and string to its caller.
X
XTable I summarizes the return codes and strings.
X
XNormally the return code is TCL_OK and the string contains the result of
Xthe command. If an error occurs in executing a command, then the return
Xcode will be TCL_ERROR and the string will describe the error condition.
XWhen TCL_ERROR is returned (or any value other than TCL_OK), the normal
Xaction is for nested command procedures to return the same code and string
Xto their callers, unwinding all pending command executions until eventually
Xthe return code and string are returned by the top-level call to Tcl_Eval.
XAt this point the application will normally display the error message for
Xthe user by printing it on the terminal or displaying it in a notifier
Xwindow.
X
XReturn codes other than TCL_OK or TCL_ERROR cause partial unwinding. For
Xexample, the break command returns a TCL_BREAK code. This causes nested
Xcommand executions to be unwound until a nested "for" or "foreach" command
Xis reached. When a "for" or "foreach" command invokes Tcl_Eval recursively,
Xit checks specially for the TCL_BREAK result. When this occurs the "for" or
X"foreach" command terminates the loop, but it doesn't return the TCL_BREAK
Xcode to its caller. Instead it returns TCL_OK. Thus no higher levels of
Xexecution are aborted. The TCL_CONTINUE return code is also handled by the
X"for" and "foreach" commands (they go on to the next loop iteration) and
XTCL_RETURN is handled by the InterpProc procedure. Only a few command
Xprocedures, like "break" and "for", know anything about special return codes
Xsuch as TCL_BREAK; other command procedures simply abort whenever they see any
Xreturn code other than TCL_OK.
X
XThe "catch" command may be used to prevent complete unwinding on TCL_ERROR
Xreturns. Catch takes an argument that is a Tcl command to execute. It
Xpasses the command to Tcl_Eval for execution, but always returns TCL_OK.
XIf an error occurs in the command, catch's command procedure detects the
XTCL_ERROR return value from Tcl_Eval, saves information about the error
Xin Tcl variables, and then returns TCL_OK to its caller. In almost all
Xcases I think the best response to an error is to abort all command
Xinvocations and notify the user; catch is provided for those few occasions
Xwhere an error is expected and can be handled without aborting.
X
X4. Tcl and Window Applications
X
XAn embeddable command language like Tcl offers particular advantages in
Xa windowing environment. This is partly because there are many interactive
Xprograms in a windowing environment (hence many places to use a command
Xlanguage) and partly because configurability is important in today's
Xwindowing environments and a language like Tcl provides the flexibility
Xto reconfigure.
X
XTcl can be used for two purposes in a window application: to configure the
Xapplication's interface actions, and to configure the application's
Xinterface appearance. These two purposes are discussed in the paragraphs
Xbelow.
X
XThe first use of Tcl is for interface actions. Ideally, each event that
Xhas any importance to the application should be bound to a Tcl command.
XEach keystroke, each mouse motion or mouse button press (or release), and
Xeach menu entry should be associated with a Tcl command. When the event
Xoccurs, it is first mapped to its Tcl command and then executed by passing
Xthe command to Tcl_Eval. The application should not take any actions
Xdirectly; all actions should first pass through Tcl. Furthermore, the
Xapplication should provide Tcl commands that allow the user to change the
XTcl command associated with any event.
X
XIn interactive windowing applications, the use of Tcl will probably not be
Xvisible to beginning users: they will manipulate the applications using
Xbuttons, menus, and other interface components. However, if Tcl is used as
Xan intermediary for all interface actions then two advantages accrue. First,
Xit becomes possible to write Tcl programs to reconfigure the interface.
XFor example, users will be able to rebind keystrokes, change mouse buttons,
Xor replace an existing operation with a more complex one specified as a set of
XTcl commands or tclprocs. The second advantage is that this approach forces
Xall of the application's functionality to be accessible through Tcl: anything
Xthat can be invoked with the mouse or keyboard can also be invoked with Tcl
Xprograms. This makes it possible to write tclprocs that simulate the actions
Xof the program, or that compose the program's basic actions into more powerful
Xactions. It also permits interactive sessions to be recorded and replayed as
Xa sequence of Tcl commands (see Section 5).
X
XThe second use for Tcl in a window application is to configure the appearance
Xof the application. All of the application's interface components
X(``widgets'' in X terminology), such as labels, buttons, text entries, menus,
Xand scrollbars, should be configured using Tcl commands. For example, in
Xthe case of a button the application (or the button widget code) should provide
XTcl commands to change the button's size and location, its text, its colors,
Xand the action (a Tcl command, of course) to invoke when the button is
Xactivated. This makes it possible for users to write Tcl programs to
Xpersonalize the layout and appearance of the applications they use. The most
Xcommon use of such reconfigurability would probably be in Tcl command files
Xread by programs automatically when they start execution. However, the
XTcl commands could also be used to change an application's appearance while
Xit is running, if that should prove useful.
X
XIf Tcl is used as described above, then it could serve as a specification
Xlanguage for user interfaces. User interface editors could be written to
Xdisplay widgets and let users re-arrange them and configure attributes such
Xas colors and associated Tcl commands. The interface editor could then
Xoutput information about the interface as a Tcl command file to be read by
Xthe application when it starts up.
XSome current interface editors output C code which must then be compiled
Xinto the application [7]; unfortunately this approach requires an
Xapplication to be recompiled in order to change its interface (or,
Xalternatively, it requires a dynamic-code-loading facility). If Tcl
Xwere used as the interface specification language then no recompilation
Xwould be necessary and a single application binary could support many
Xdifferent interfaces.
X
X5. Communication Between Applications
X
XThe advantages of an embedded command language like Tcl become even
Xgreater if all of the tools in an environment are based on the same
Xlanguage. First, users need only learn one basic command language;
Xto move from one application to another they need only learn the
X(few?) application-specific commands for the new application. Second,
Xgeneric interface editors become possible, as described in the previous
Xsection. Third, and most important in my view, Tcl can provide a means
Xof communication between applications.
X
XI have implemented a communication mechanism for X11 in the form of an
Xadditional Tcl command called "send". For send to work, each Tcl
Xinterpreter associated with an X11 application is given a textual name,
Xsuch as "xmh" for an X mail handler or mx.foo.c for a window in which
Xmx is displaying a file named foo.c. The send command takes two arguments:
Xthe name of an interpreter and a Tcl command to execute in that interpreter.
X"Send" arranges for the command to be passed to the process containing the
Xnamed interpreter; the command is executed by that interpreter and the
Xresults (return code and string) are returned to the application that
Xissued the "send" command.
X
XThe X11 implementation of send uses a special property attached to the
Xroot window. The property stores the names of all the interpreters plus
Xa window identifier for each interpreter. A command is sent to an interpreter
Xby appending it to a particular property in the interpreter's associated
Xwindow. The property change is detected by the process that owns the
Xinterpreter; it reads the property, executes the command, and appends
Xresult information onto a property associated with the sending application.
XFinally, the sending application detects this change of property, reads
Xthe result information, and returns it as the result of the send command.
X
XThe send command provides a powerful way for one application to control
Xanother. For example, a debugger could send commands to an editor to
Xhighlight the current source line as it single-steps through a program.
XOr, a user interface editor could use send to manipulate an application's
Xinterface directly: rather than modifying a dummy version of the
Xapplication's interface displayed by the interface editor, the interface
Xeditor could use send to modify the interface of a ``live'' application,
Xwhile also saving the configuration for a configuration file. This would
Xallow an interface designer to try out the look and feel of a new interface
Xincrementally as changes are made to the interface.
X
XAnother example of using send is for changing user preferences. If one
Xuser walks up to a display that has been configured for some other user,
Xthe new user could run a program that finds out about all the existing
Xapplications on the screen (by querying the property that contains their
Xnames), reads the new user's configuration file for each application, and
Xsends commands to that application to reconfigure it for the new user's
Xpreferences. When the old user returns, he or she could invoke the same
Xprogram to restore the original preferences.
X
X"Send" could also be used to record interactive sessions involving multiple
Xapplications and then replay the sessions later (e.g. for demonstration
Xpurposes). This would require an additional Tcl command called trace;
Xtrace would take a single argument (a Tcl command string) and cause that
Xcommand string to be executed before each other command was executed in
Xthat interpreter. Within a single application, trace could be used to record
Xeach Tcl command before it is executed, so that the commands could be replayed
Xlater. In a multi-application environment, a recorder program could be built
Xusing send. The recorder sends a trace command to each application to be
Xrecorded. The trace command arranges for information to be sent back
Xto the recorder about each command executed in that application. The
Xrecorder then logs information about which applications executed which
Xcommands. The recorder can reexecute the commands by "send"-ing them
Xback to the applications again. The trace command does not yet exist
Xin Tcl, but it could easily be added.
X
XSend provides a much more powerful mechanism for communication between
Xapplications than is available today. The only easy-to-use form of
Xcommunication for today's applications is the selection or cut buffer:
Xa single string of text that may be set by one application and read by
Xanother. Send provides a more general form of communication akin to
Xremote procedure call [3]. If all of an application's functionality is
Xmade available through Tcl, as described in Section 4, then send makes
Xall of each application's functionality available to other applications
Xas well.
X
XIf Tcl (and send) were to become widely used in window applications, I
Xbelieve that a better kind of interactive environment would arise,
Xconsisting of a large number of small specialized applications rather
Xthan a few monolithic ones. Today's applications cannot communicate
Xwith each other very well, so each application must incorporate all
Xthe functionality that it needs. For example, some window-based debuggers
Xcontain built-in text editors so that they can highlight the current
Xpoint of execution. With Tcl and send, the debugger and the editor could
Xbe distinct programs, with each sending commands to the other as necessary.
XIdeally, monolithic applications could be replaced by lots of small
Xapplications that work together in exciting new ways, just as the UNIX
Xshells allowed lots of small text processing applications to be combined
Xtogether. I think that Tcl, or some other language like it, will provide
Xthe glue that binds together the windowing applications of the 1990's.
X
X6. Status and Performance
X
XThe Tcl language was designed in the fall of 1987 and implemented in the
Xwinter of 1988. In the spring of 1988 I incorporated Tcl into the mx
Xeditor (which already existed, but with an inferior command language),
Xand also into a companion terminal emulator called Tx. Both of these
Xprograms have been in use by a small user community at Berkeley for
Xthe last year and a half. All of the Tcl language facilities exist as
Xdescribed above, except that the send command is still in prototype form
Xand trace hasn't been implemented. Some of the features described in
XSection 4, such as menu and keystroke bindings, are implemented in mx, but
Xin an ad hoc fashion: Tcl is not yet integrated with a widget set. I am
Xcurrently building a new toolkit and widget set that is based entirely on
XTcl. When it is completed, I expect it to provide all of the features
Xdescribed in Section 4. As of this writing, the implementation has barely
Xbegun.
X
XTable II shows how long it takes Tcl to execute various commands on two
Xdifferent workstations. On Sun-3 workstations, the average time for simple
Xcommands is about 500 microseconds, while on DECstation 3100's the average
Xtime per command is about 160 microseconds. Although mx does not currently
Xuse a Tcl command for each mouse motion event, the times in Table II suggest
Xthat this would be possible, even on Sun-3 workstations, without significant
Xdegradation of response. For example, if mouse motion events occur 100 times
Xper second, the Tcl overhead for dispatching one command per event will
Xconsume only about 1-2% of a Sun-3 processor.
XFor the ways in which Tcl is currently used (keystroke and menu bindings
Xconsisting of a few commands), there are no noticeable delays associated
Xwith Tcl. For application-specific commands such as those for the mx editor,
Xthe time to execute the command is much greater than the time required by
XTcl to parse it and call the command procedure.
X
XThe Tcl library is small enough to be used in a wide variety of programs, even
Xon systems without mechanisms for sharing libraries. The Tcl code consists of
Xabout 7000 lines of C code (about half of which is comments). When compiled
Xfor a Motorola 68000, it generates about 27000 bytes of object code.
X
X7. Comparisons
X
XThe Tcl language has quite a bit of surface similarity to Lisp, except
Xthat Tcl uses curly braces or brackets instead of parentheses and no braces
Xare needed around the outermost level of a command. The greatest difference
Xbetween Tcl and Lisp is that Lisp evaluates arguments by default, whereas
Xin Tcl arguments are not evaluated unless surrounded by brackets. This
Xmeans that more typing effort is required in Tcl if an argument is to be
Xevaluated, and more typing effort is required in Lisp if an argument is
Xto be quoted (not evaluated).
XIt appeared to me that no-evaluation is usually the desired result in
Xarguments to a command language, so I made this the default in Tcl.
XTcl also has fewer data types than Lisp; this was done in order to simplify
Xthe interface between the Tcl library and an enclosing C application.
X
XThe Emacs editor is similar to Tcl in that it provides a framework that
Xcan be used to control many different application programs. For example,
Xsubprocesses can be run in Emacs windows and users can write Emacs command
Xscripts that (a) generate command sequences for input to the applications
Xand (b) re-format the output of applications. This allows users to embellish
Xthe basic facilities of applications, edit their output, and so on.
X
XThe difference between Emacs and Tcl is that the programmability is
Xcentralized in Emacs: applications cannot talk to each other unless Emacs
Xacts as intermediary (e.g. to set up a new communication mechanism between
Xtwo applications, code must be written in Emacs to pass information back
Xand forth between the applications). The Tcl approach is decentralized:
Xeach application has its own command interpreter and applications may
Xcommunicate directly with each other.
X
XLastly, it is interesting to compare Tcl to NeWS [9], a window system that
Xis based on the Postscript language. NeWS allows applications to down-load
Xa window server in order to change the user interface and modify other
Xaspects of the system. In a sense, this is similar to the "send" command in
XTcl, in that applications may send programs to the server for execution.
XHowever, the NeWS mechanism is less general than Tcl: NeWS applications
Xgenerate Postscript programs as output but they do not necessarily respond
Xto Postscript programs as input. In other words, NeWS applications can
Xaffect each others' interfaces, by controlling the server, but they cannot
Xdirectly invoke each others' application-specific operations as they can
Xwith Tcl.
X
XTo summarize, the Tcl approach is less centralized than either the Emacs
Xor NeWS approaches. For a windowing environment with large numbers of
Xindependent tools, I think the decentralized approach makes sense.
XIn fairness to Emacs, it's important to point out that Emacs wasn't designed
Xfor this environment, and that Emacs works quite nicely in the environment
Xfor which it was designed (ASCII terminals with batch-style applications).
XIt's also worth noting that direct communication between applications was
Xnot an explicit goal of the NeWS system design.
X
X8. Conclusions
X
XI think that Tcl could improve our interactive environments in three general
Xways. First, Tcl can be used to improve individual tools by providing them
Xwith a programmable command language; this allows users to customize tools
Xand extend their functionality. Second, Tcl can provide a uniform command
Xlanguage across a range of tools; this makes it easier for users to program
Xthe tools and also allows tool-independent facilities to be built, such as
Xinterface editors. Third, Tcl provides a mechanism for tools to control
Xeach other; this encourages a more modular approach to windowing applications
Xand makes it possible to re-use old applications in new ways. In my opinion
Xthe third benefit is potentially the most important.
X
XMy experiences with Tcl so far are positive but limited. Tcl needs a larger
Xuser community and a more complete integration into a windowing toolkit before
Xit can be fully evaluated. The Tcl library source code is currently available
Xto the public in a free, unlicensed form, and I hope to produce a Tcl-based
Xtoolkit in the near future.
X
X9. Acknowledgments
X
XThe members of the Sprite project acted as guinea pigs for the editor and
Xterminal emulator based on Tcl; without their help the language would
Xnot have evolved to its current state. Fred Douglis, John Hartman,
XKen Shirriff, and Brent Welch provided helpful comments that improved the
Xpresentation of this paper.
X
X10. References
X
X[1] Abelson, H. and Sussman, G.J.
X Structure and Interpretation of Computer Programs,
X MIT Press, Cambridge, MA, 1985.
X
X[2] Adobe Systems, Inc.
X Postscript Language Tutorial and Cookbook,
X Addison-Wesley, Reading, MA, 1985.
X
X[3] Birrell, A. and Nelson, B.
X ``Implementing Remote Procedure Calls.''
X ACM Transactions on Computer Systems,
X Vol. 2, No. 1, February 1986, pp. 39-59.
X
X[4] Brodie, L.
X Starting FORTH: An Introduction to the FORTH Language and
X Operating System for Beginners and Professionals,
X Prentice Hall, Englewood Cliffs, NJ, 1981.
X
X[5] Kernighan, B.W. and Pike, R.
X The UNIX Programming Environment,
X Prentice Hall, Englewood Cliffs, NJ, 1984.
X
X[6] Kernighan, B.W. and Ritchie, D.M.
X The C Programming Language,
X Second Edition,
X Prentice Hall, Englewood Cliffs, NJ, 1988.
X
X[7] Mackey, K., Downs, M., Duffy, J., and Leege, J.
X ``An Interactive Interface Builder for Use with Ada Programs,''
X Xhibition Conference Proceedings, 1989.
X
X[8] Stallman, R.
X GNU Emacs Manual,
X Fourth Edition,
X Version 17,
X February 1986.
X
X[9] Sun Microsystems, Inc.
X NeWS Technical Overview,
X Sun Microsystems, Inc.
X PN 800-1498-05, 1987.
X
END_OF_FILE
if test 41391 -ne `wc -c <'tcl6.1/doc/usenix.text'`; then
echo shar: \"'tcl6.1/doc/usenix.text'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/usenix.text'
fi
echo shar: End of archive 31 $of 33$.
cp /dev/null ark31isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 6:01:32 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 100
Archive-name: tcl/part32
Environment: UNIX

# "End of archive 32 (of 33)."
# Contents: tcl6.1/doc/Tcl.man.3

# Wrapped by karl@one on Tue Nov 12 19:44:33 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/Tcl.man.3' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Tcl.man.3'\"
else
echo shar: Extracting \"'tcl6.1/doc/Tcl.man.3'\" $41512 characters$
sed "s/^X//" >'tcl6.1/doc/Tcl.man.3' <<'END_OF_FILE'
X.TP
X\fBinfo vars\fR ?\fIpattern\fR?
XIf \fIpattern\fR isn't specified,
Xreturns a list of all the names of currently-visible variables, including
Xboth locals and currently-visible globals.
XIf \fIpattern\fR is specified, only those names matching \fIpattern\fR
Xare returned. Matching is determined using the same rules as for
X\fBstring match\fR.
X.RE
X.TP
X\fBjoin \fIlist \fR?\fIjoinString\fR?
X.VS
XThe \fIlist\fR argument must be a valid Tcl list.
XThis command returns the string
Xformed by joining all of the elements of \fIlist\fR together with
X\fIjoinString\fR separating each adjacent pair of elements.
XThe \fIjoinString\fR argument defaults to a space character.
X.VE
X.TP
X\fBlappend \fIvarName value \fR?\fIvalue value ...\fR?
X.VS
XTreat the variable given by \fIvarName\fR as a list and append
Xeach of the \fIvalue\fR arguments to that list as a separate
Xelement, with spaces between elements.
XIf \fIvarName\fR doesn't exist, it is created as a list with elements
Xgiven by the \fIvalue\fR arguments.
X\fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs
Xare appended as list elements rather than raw text.
XThis command provides a relatively efficient way to build up
Xlarge lists. For example, ``\fBlappend a $b\fR'' is much
Xmore efficient than ``\fBset a [concat $a [list $b]]\fR'' when
X\fB$a\fR is long.
X.TP
X\fBlindex \fIlist index\fR
XTreats \fIlist\fR as a Tcl list and returns the \fIindex\fR'th element
Xfrom it (0 refers to the first element of the list).
XIn extracting the element, \fIlindex\fR observes the same rules
Xconcerning braces and quotes and backslashes as the Tcl command
Xinterpreter; however, variable
Xsubstitution and command substitution do not occur.
XIf \fIindex\fR is negative or greater than or equal to the number
Xof elements in \fIvalue\fR, then an empty
Xstring is returned.
X.TP
X\fBlinsert \fIlist index element \fR?\fIelement element ...\fR?
XThis command produces a new list from \fIlist\fR by inserting all
Xof the \fIelement\fR arguments just before the \fIindex\fRth
Xelement of \fIlist\fR. Each \fIelement\fR argument will become
Xa separate element of the new list. If \fIindex\fR is less than
Xor equal to zero, then the new elements are inserted at the
Xbeginning of the list. If \fIindex\fR is greater than or equal
Xto the number of elements in the list, then the new elements are
Xappended to the list.
X.VE
X.TP
X\fBlist \fIarg \fR?\fIarg ...\fR?
XThis command returns a list comprised of all the \fIarg\fRs. Braces
Xand backslashes get added as necessary, so that the \fBindex\fR command
Xmay be used on the result to re-extract the original arguments, and also
Xso that \fBeval\fR may be used to execute the resulting list, with
X\fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising
Xits arguments. \fBList\fR produces slightly different results than
X\fBconcat\fR: \fBconcat\fR removes one level of grouping before forming
Xthe list, while \fBlist\fR works directly from the original arguments.

XFor example, the command
X.RS
X.DS

X\fBlist a b {c d e} {f {g h}}
X.DE
Xwill return
X.DS
X\fBa b {c d e} {f {g h}}
X.DE
Xwhile \fBconcat\fR with the same arguments will return
X.DS
X\fBa b c d e f {g h}\fR
X.DE
X.RE
X.br
X.VS
X.TP
X\fBllength \fIlist\fR
XTreats \fIlist\fR as a list and returns a decimal string giving
Xthe number of elements in it.
X.TP
X\fBlrange \fIlist first last
X\fIList\fR must be a valid Tcl list. This command will
Xreturn a new list consisting of elements
X\fIfirst\fR through \fIlast\fR, inclusive.
X\fILast\fR may be \fBend\fR (or any
Xabbreviation of it) to refer to the last element of the list.
XIf \fIfirst\fR is less than zero, it is treated as if it were zero.
XIf \fIlast\fR is greater than or equal to the number of elements
Xin the list, then it is treated as if it were \fBend\fR.
XIf \fIfirst\fR is greater than \fIlast\fR then an empty string
Xis returned.
XNote: ``\fBlrange \fIlist first first\fR'' does not always produce the
Xsame result as ``\fBlindex \fIlist first\fR'' (although it often does
Xfor simple fields that aren't enclosed in braces); it does, however,
Xproduce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR''
X.TP
X\fBlreplace \fIlist first last \fR?\fIelement element ...\fR?
XReturns a new list formed by replacing one or more elements of
X\fIlist\fR with the \fIelement\fR arguments.
X\fIFirst\fR gives the index in \fIlist\fR of the first element
Xto be replaced.
XIf \fIfirst\fR is less than zero then it refers to the first
Xelement of \fIlist\fR; the element indicated by \fIfirst\fR
Xmust exist in the list.
X\fILast\fR gives the index in \fIlist\fR of the last element
Xto be replaced; it must be greater than or equal to \fIfirst\fR.
X\fILast\fR may be \fBend\fR (or any abbreviation of it) to indicate
Xthat all elements between \fIfirst\fR and the end of the list should
Xbe replaced.
XThe \fIelement\fR arguments specify zero or more new arguments to
Xbe added to the list in place of those that were deleted.
XEach \fIelement\fR argument will become a separate element of
Xthe list.
XIf no \fIelement\fR arguments are specified, then the elements
Xbetween \fIfirst\fR and \fIlast\fR are simply deleted.
X.TP
X\fBlsearch \fIlist pattern\fR
XSearch the elements of \fIlist\fR to see if one of them matches
X\fIpattern\fR.
XIf so, the command returns the index of the first matching
Xelement.
XIf not, the command returns \fB\-1\fR.
XPattern matching is done in the same way as for the \fBstring match\fR
Xcommand.
X.TP
X\fBlsort \fIlist\fR
XSort the elements of \fIlist\fR, returning a new list in sorted
Xorder.
XASCII sorting is used, with the result in increasing order.
X.VE
X.TP
X\fBopen \fIfileName\fR ?\fIaccess\fR?
X.VS
XOpens a file and returns an identifier
Xthat may be used in future invocations
Xof commands like \fBread\fR, \fBwrite\fR, and \fBclose\fR.
X\fIFileName\fR gives the name of the file to open; if it starts with
Xa tilde then tilde substitution is performed as described for
X\fBTcl_TildeSubst\fR.
XIf the first character of \fIfileName\fR is ``|'' then the
Xremaining characters of \fIfileName\fR are treated as a command
Xpipeline to invoke, in the same style as for \fBexec\fR.
XIn this case, the identifier returned by \fBopen\fR may be used
Xto write to the command's input pipe or read from its output pipe.
XThe \fIaccess\fR argument indicates the way in which the file
X(or command pipeline) is to be accessed.
XIt may have any of the following values:
X.RS
X.TP
X\fBr\fR
XOpen the file for reading only; the file must already exist.
X.TP
X\fBr+\fR
XOpen the file for both reading and writing; the file must
Xalready exist.
X.TP
X\fBw\fR
XOpen the file for writing only. Truncate it if it exists. If it doesn't
Xexist, create a new file.
X.TP
X\fBw+\fR
XOpen the file for reading and writing. Truncate it if it exists.
XIf it doesn't exist, create a new file.
X.TP
X\fBa\fR
XOpen the file for writing only. The file must already exist, and the file
Xis positioned so that new data is appended to the file.
X.TP
X\fBa+\fR
XOpen the file for reading and writing. The file must already exist, and
Xthe initial access position is set to the end of the file.
X.PP
X\fIAccess\fR defaults to \fBr\fR.
XIf a file is opened for both reading and writing, then \fBseek\fR
Xmust be invoked between a read and a write, or vice versa (this
Xrestriction does not apply to command pipelines opened with \fBopen\fR).
XWhen \fIfileName\fR specifies a command pipeline and a write-only access
Xis used, then standard output from the pipeline is directed to the
Xcurrent standard output unless overridden by the command.
XWhen \fIfileName\fR specifies a command pipeline and a read-only access
Xis used, then standard input from the pipeline is taken from the
Xcurrent standard input unless overridden by the command.
X.RE
X.VE
X.TP
X\fBproc \fIname args body\fR
XThe \fBproc\fR command creates a new Tcl command procedure,
X\fIname\fR, replacing
Xany existing command there may have been by that name. Whenever the
Xnew command is invoked, the contents of \fIbody\fR will be executed
Xby the Tcl interpreter. \fIArgs\fR specifies the formal arguments to the
Xprocedure. It consists of a list, possibly empty, each of whose
Xelements specifies
Xone argument. Each argument specifier is also a list with either
Xone or two fields. If there is only a single field in the specifier,
Xthen it is the name of the argument; if there are two fields, then
Xthe first is the argument name and the second is its default value.
Xbraces and backslashes may be used in the usual way to specify
Xcomplex default values.
X.IP
XWhen \fIname\fR is invoked, a local variable
Xwill be created for each of the formal arguments to the procedure; its
Xvalue will be the value of corresponding argument in the invoking command
Xor the argument's default value.
XArguments with default values need not be
Xspecified in a procedure invocation. However, there must be enough
Xactual arguments for all the
Xformal arguments that don't have defaults, and there must not be any extra
Xactual arguments. There is one special case to permit procedures with
Xvariable numbers of arguments. If the last formal argument has the name
X\fBargs\fR, then a call to the procedure may contain more actual arguments
Xthan the procedure has formals. In this case, all of the actual arguments
Xstarting at the one that would be assigned to \fBargs\fR are combined into
Xa list (as if the \fBlist\fR command had been used); this combined value
Xis assigned to the local variable \fBargs\fR.
X.IP
XWhen \fIbody\fR is being executed, variable names normally refer to
Xlocal variables, which are created automatically when referenced and
Xdeleted when the procedure returns. One local variable is automatically
Xcreated for each of the procedure's arguments.
XGlobal variables can only be accessed by invoking
Xthe \fBglobal\fR command.
X.IP
XThe \fBproc\fR command returns the null string. When a procedure is
Xinvoked, the procedure's return value is the value specified in a
X\fBreturn\fR command. If the procedure doesn't execute an explicit
X\fBreturn\fR, then its return value is the value of the last command
Xexecuted in the procedure's body.
XIf an error occurs while executing the procedure
Xbody, then the procedure-as-a-whole will return that same error.
X.TP
X\fBputs \fIfileId string \fR?\fBnonewline\fR?
X.VS
XWrites the characters given by \fIstring\fR to the file given
Xby \fIfileId\fR.
X\fBPuts\fR normally outputs a newline character after \fIstring\fR,
Xbut this feature may be suppressed by specifying the \fBnonewline\fR
Xargument.
XOutput to files is buffered internally by Tcl; the \fBflush\fR
Xcommand may be used to force buffered characters to be output.
X\fIFileId\fR must have been the return
Xvalue from a previous call to \fBopen\fR, or it may be
X\fBstdout\fR or \fBstderr\fR to refer to one of the standard I/O
Xchannels; it must refer to a file that was opened for
Xwriting.
X.TP
X\fBpwd\fR
X.br
XReturns the path name of the current working directory.
X.TP
X\fBread \fIfileId\fR
X.TP
X\fBread \fIfileId \fBnonewline\fR
X.TP
X\fBread \fIfileId numBytes\fR
XIn the first form, all of the remaining bytes are read from the file
Xgiven by \fIfileId\fR; they are returned as the result of the command.
XIf \fBnonewline\fR is specified as an additional argument, then the last
Xcharacter of the file is discarded if it is a newline.
XIn the third form, the extra argument specifies how many bytes to read;
Xexactly this many bytes will be read and returned, unless there are fewer than
X\fInumBytes\fR bytes left in the file; in this case, all the remaining
Xbytes are returned.
X\fIFileId\fR must be \fBstdin\fR or the return
Xvalue from a previous call to \fBopen\fR; it must
Xrefer to a file that was opened for reading.
X.TP
X\fBregexp \fR?\fB\-indices\fR? \fR?\fB\-nocase\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR?
XDetermines whether the regular expression \fIexp\fR matches part or
Xall of \fIstring\fR and returns 1 if it does, 0 if it doesn't.
XSee REGULAR EXPRESSIONS above for complete information on the
Xsyntax of \fIexp\fR and how it is matched against \fIstring\fR.
X.RS
X.LP
XIf the \fB\-nocase\fR switch is specified then upper-case
Xcharacters in \fIstring\fR
Xare treated as lower case during the matching process.
XThe \fB\-nocase\fR switch must be specified before \fIexp\fR and
Xmay not be abbreviated.
X.LP
XIf additional arguments are specified after \fIstring\fR then they
Xare treated as the names of variables to use to return
Xinformation about which part(s) of \fIstring\fR matched \fIexp\fR.
X\fIMatchVar\fR will be set to the range of \fIstring\fR that
Xmatched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain
Xthe characters in \fIstring\fR that matched the leftmost parenthesized
Xsubexpression within \fIexp\fR, the next \fIsubMatchVar\fR will
Xcontain the characters that matched the next parenthesized
Xsubexpression to the right in \fIexp\fR, and so on.
X.LP
XNormally, \fImatchVar\fR and the \fIsubMatchVar\fRs are set to hold
Xthe matching characters from \fBstring\fR.
XHowever, if the \fB\-indices\fR switch is specified then each variable
Xwill contain a list of two decimal strings giving the indices
Xin \fIstring\fR of the first and last characters in the matching
Xrange of characters.
XThe \fB\-indices\fR switch must be specified before the \fIexp\fR
Xargument and may not be abbreviated.
X.LP
XIf there are more more \fIsubMatchVar\fR's than parenthesized
Xsubexpressions within \fIexp\fR, or if a particular subexpression
Xin \fIexp\fR doesn't match the string (e.g. because it was in a
Xportion of the expression that wasn't matched), then the corresponding
X\fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR
Xhas been specified or to an empty string otherwise.
X.RE
X.TP
X\fBregsub \fR?\fB\-all\fR? ?\fB\-nocase\fR? \fIexp string subSpec varName\fR
XThis command matches the regular expression \fIexp\fR against
X\fIstring\fR using the rules described in REGULAR EXPRESSIONS
Xabove.
XIf there is no match, then the command returns 0 and does nothing
Xelse.
XIf there is a match, then the command returns 1 and also copies
X\fIstring\fR to the variable whose name is given by \fIvarName\fR.
XWhen copying \fIstring\fR, the portion of \fIstring\fR that
Xmatched \fIexp\fR is replaced with \fIsubSpec\fR.
XIf \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced
Xin the substitution with the portion of \fIstring\fR that
Xmatched \fIexp\fR.
XIf \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit
Xbetween 1 and 9, then it is replaced in the substitution with
Xthe portion of \fIstring\fR that matched the \fIn\fR-th
Xparenthesized subexpression of \fIexp\fR.
XAdditional backslashes may be used in \fIsubSpec\fR to prevent special
Xinterpretation of ``&'' or ``\e0'' or ``\e\fIn\fR'' or
Xbackslash.
XThe use of backslashes in \fIsubSpec\fR tends to interact badly
Xwith the Tcl parser's use of backslashes, so it's generally
Xsafest to enclose \fIsubSpec\fR in braces if it includes
Xbackslashes.
XIf the \fB\-all\fR argument is specified, then all ranges in
X\fIstring\fR that match \fIexp\fR are found and substitution is
Xperformed for each of these ranges; otherwise only the first
Xmatching range is found and substituted.
XIf \fB\-all\fR is specified, then ``&'' and ``\e\fIn\fR''
Xsequences are handled for each substitution using the information
Xfrom the corresponding match.
XIf the \fB\-nocase\fR argument is specified, then upper-case
Xcharacters in \fIstring\fR are converted to lower-case before
Xmatching against \fIexp\fR; however, substitutions specified
Xby \fIsubSpec\fR use the original unconverted form of \fIstring\fR.
XThe \fB\-all\fR and \fB\-nocase\fR arguments must be specified
Xexactly: no abbreviations are permitted.
X.VE
X.TP
X\fBrename \fIoldName newName\fR
XRename the command that used to be called \fIoldName\fR so that it
Xis now called \fInewName\fR. If \fInewName\fR is an empty string
X(e.g. {}) then \fIoldName\fR is deleted. The \fBrename\fR command
Xreturns an empty string as result.
X.TP
X\fBreturn \fR?\fIvalue\fR?
XReturn immediately from the current procedure
X(or top-level command or \fBsource\fR command),
Xwith \fIvalue\fR as the return value. If \fIvalue\fR is not specified,
Xan empty string will be returned as result.
X.TP
X\fBscan \fIstring format varname1 \fR?\fIvarname2 ...\fR?
XThis command parses fields from an input string in the same fashion
Xas the C \fBsscanf\fR procedure. \fIString\fR gives the input to
Xbe parsed and \fIformat\fR indicates how to parse it, using \fB%\fR
Xfields as in \fBsscanf\fR. All of the \fBsscanf\fR options are valid;
Xsee the \fBsscanf\fR man page for details. Each \fIvarname\fR gives
Xthe name of a variable; when a field is scanned from \fIstring\fR,
Xthe result is converted back into a string and assigned to the
Xcorresponding \fIvarname\fR. The only unusual conversion is for
X\fB%c\fR. For \fB%c\fR conversions a single character value is
Xconverted to a decimal string, which is then assigned to the
Xcorresponding \fIvarname\fR;
X.VS
Xno field width may be specified for this conversion.
X.TP
X\fBseek \fIfileId offset \fR?\fIorigin\fR?
XChange the current access position for \fIfileId\fR.
XThe \fIoffset\fR and \fIorigin\fR arguments specify the position at
Xwhich the next read or write will occur for \fIfileId\fR.
X\fIOffset\fR must be a number (which may be negative) and \fIorigin\fR
Xmust be one of the following:
X.RS
X.TP
X\fBstart\fR
XThe new access position will be \fIorigin\fR bytes from the start
Xof the file.
X.TP
X\fBcurrent\fR
XThe new access position will be \fIorigin\fR bytes from the current
Xaccess position; a negative \fIorigin\fR moves the access position
Xbackwards in the file.
X.TP
X\fBend\fR
XThe new access position will be \fIorigin\fR bytes from the end of
Xthe file. A negative \fIorigin\fR places the access position before
Xthe end-of-file, and a positive \fIorigin\fR places the access position
Xafter the end-of-file.
X.LP
XThe \fIorigin\fR argument defaults to \fBstart\fR.
X\fIFileId\fR must have been the return
Xvalue from a previous call to \fBopen\fR, or it may be \fBstdin\fR,
X\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O
Xchannels.
XThis command returns an empty string.
X.RE
X.VE
X.TP
X\fBset \fIvarname \fR?\fIvalue\fR?
XReturns the value of variable \fIvarname\fR.
XIf \fIvalue\fR is specified, then set
Xthe value of \fIvarname\fR to \fIvalue\fR, creating a new variable
Xif one doesn't already exist, and return its value.
X.VS

XIf \fIvarName\fR contains an open parenthesis and ends with a

Xclose parenthesis, then it refers to an array element: the characters
Xbefore the open parenthesis are the name of the array, and the characters
Xbetween the parentheses are the index within the array.
XOtherwise \fIvarName\fR refers to a scalar variable.
X.VE
XIf no procedure is active, then \fIvarname\fR refers to a global
Xvariable.
XIf a procedure is active, then \fIvarname\fR refers to a parameter
Xor local variable of the procedure, unless the \fIglobal\fR command
Xhas been invoked to declare \fIvarname\fR to be global.
X.TP
X\fBsource \fIfileName\fR
XRead file \fIfileName\fR and pass the contents to the Tcl interpreter
Xas a sequence of commands to execute in the normal fashion. The return
Xvalue of \fBsource\fR is the return value of the last command executed
Xfrom the file. If an error occurs in executing the contents of the
Xfile, then the \fBsource\fR command will return that error.
XIf a \fBreturn\fR command is invoked from within the file, the remainder of
Xthe file will be skipped and the \fBsource\fR command will return
Xnormally with the result from the \fBreturn\fR command.
XIf \fIfileName\fR starts with a tilde, then it is tilde-substituted
Xas described in the \fBTcl_TildeSubst\fR manual entry.
X.TP
X\fBsplit \fIstring \fR?\fIsplitChars\fR?
XReturns a list created by splitting \fIstring\fR at each character
Xthat is in the \fIsplitChars\fR argument.
XEach element of the result list will consist of the
Xcharacters from \fIstring\fR between instances of the
Xcharacters in \fIsplitChars\fR.
XEmpty list elements will be generated if \fIstring\fR contains
Xadjacent characters in \fIsplitChars\fR, or if the first or last
Xcharacter of \fIstring\fR is in \fIsplitChars\fR.
XIf \fIsplitChars\fR is an empty string then each character of
X\fIstring\fR becomes a separate element of the result list.
X\fISplitChars\fR defaults to the standard white-space characters.
XFor example,
X.RS
X.DS
X\fBsplit "comp.unix.misc" .\fR
X.DE
Xreturns \fB"comp unix misc"\fR and
X.DS
X\fBsplit "Hello world" {}\fR
X.DE
Xreturns \fB"H e l l o { } w o r l d"\fR.
X.VE
X.RE
X.TP
X\fBstring \fIoption arg \fR?\fIarg ...?\fR
XPerform one of several string operations, depending on \fIoption\fR.
XThe legal \fIoption\fRs (which may be abbreviated) are:
X.RS
X.TP
X\fBstring compare \fIstring1 string2\fR
XPerform a character-by-character comparison of strings \fIstring1\fR and
X\fIstring2\fR in the same way as the C \fBstrcmp\fR procedure. Return
X-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically
Xless than, equal to, or greater than \fIstring2\fR.
X.TP
X\fBstring first \fIstring1 string2\fR
XSearch \fIstring2\fR for a sequence of characters that exactly match
Xthe characters in \fIstring1\fR. If found, return the index of the
Xfirst character in the first such match within \fIstring2\fR. If not
Xfound, return -1.
X.br
X.VS
X.TP
X\fBstring index \fIstring charIndex\fR
XReturns the \fIcharIndex\fR'th character of the \fIstring\fR
Xargument. A \fIcharIndex\fR of 0 corresponds to the first
Xcharacter of the string.
XIf \fIcharIndex\fR is less than 0 or greater than
Xor equal to the length of the string then an empty string is
Xreturned.
X.VE
X.TP
X\fBstring last \fIstring1 string2\fR
XSearch \fIstring2\fR for a sequence of characters that exactly match
Xthe characters in \fIstring1\fR. If found, return the index of the
Xfirst character in the last such match within \fIstring2\fR. If there
Xis no match, then return \-1.
X.br
X.VS
X.TP
X\fBstring length \fIstring\fR
XReturns a decimal string giving the number of characters in \fIstring\fR.
X.VE
X.TP
X\fBstring match \fIpattern\fR \fIstring\fR
XSee if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0
Xif it doesn't. Matching is done in a fashion similar to that
Xused by the C-shell. For the two strings to match, their contents
Xmust be identical except that the following special sequences
Xmay appear in \fIpattern\fR:
X.RS
X.IP \fB*\fR 10
XMatches any sequence of characters in \fIstring\fR,
Xincluding a null string.
X.IP \fB?\fR 10
XMatches any single character in \fIstring\fR.
X.IP \fB[\fIchars\fB]\fR 10
XMatches any character in the set given by \fIchars\fR. If a sequence
Xof the form
X\fIx\fB\-\fIy\fR appears in \fIchars\fR, then any character
Xbetween \fIx\fR and \fIy\fR, inclusive, will match.
X.IP \fB\e\fIx\fR 10
XMatches the single character \fIx\fR. This provides a way of
Xavoiding the special interpretation of the characters
X\fB*?[]\e\fR in \fIpattern\fR.
X.RE
X.br
X.VS
X.TP
X\fBstring range \fIstring first last\fR
XReturns a range of consecutive characters from \fIstring\fR, starting
Xwith the character whose index is \fIfirst\fR and ending with the
Xcharacter whose index is \fIlast\fR. An index of 0 refers to the
Xfirst character of the string. \fILast\fR may be \fBend\fR (or any
Xabbreviation of it) to refer to the last character of the string.
XIf \fIfirst\fR is less than zero then it is treated as if it were zero, and
Xif \fIlast\fR is greater than or equal to the length of the string then
Xit is treated as if it were \fBend\fR. If \fIfirst\fR is greater than
X\fIlast\fR then an empty string is returned.
X.TP
X\fBstring tolower \fIstring\fR
XReturns a value equal to \fIstring\fR except that all upper case
Xletters have been converted to lower case.
X.TP
X\fBstring toupper \fIstring\fR
XReturns a value equal to \fIstring\fR except that all lower case
Xletters have been converted to upper case.
X.TP
X\fBstring trim \fIstring\fR ?\fIchars\fR?
XReturns a value equal to \fIstring\fR except that any leading
Xor trailing characters from the set given by \fIchars\fR are
Xremoved.
XIf \fIchars\fR is not specified then white space is removed
X(spaces, tabs, newlines, and carriage returns).
X.TP
X\fBstring trimleft \fIstring\fR ?\fIchars\fR?
XReturns a value equal to \fIstring\fR except that any
Xleading characters from the set given by \fIchars\fR are
Xremoved.
XIf \fIchars\fR is not specified then white space is removed
X(spaces, tabs, newlines, and carriage returns).
X.TP
X\fBstring trimright \fIstring\fR ?\fIchars\fR?
XReturns a value equal to \fIstring\fR except that any
Xtrailing characters from the set given by \fIchars\fR are
Xremoved.
XIf \fIchars\fR is not specified then white space is removed
X(spaces, tabs, newlines, and carriage returns).
X.RE
X.TP
X\fBtell \fIfileId\fR
XReturns a decimal string giving the current access position in
X\fIfileId\fR.
X\fIFileId\fR must have been the return
Xvalue from a previous call to \fBopen\fR, or it may be \fBstdin\fR,
X\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O
Xchannels.
X.VE
X.TP
X\fBtime \fIcommand\fR ?\fIcount\fR?
XThis command will call the Tcl interpreter \fIcount\fR
Xtimes to execute \fIcommand\fR (or once if \fIcount\fR isn't
Xspecified). It will then return a string of the form
X.RS
X.DS
X\fB503 microseconds per iteration\fR
X.DE
Xwhich indicates the average amount of time required per iteration,
Xin microseconds.
XTime is measured in elapsed time, not CPU time.
X.RE
X.TP
X\fBtrace \fIoption\fR ?\fIarg arg ...\fR?
X.VS
XCause Tcl commands to be executed whenever certain operations are
Xinvoked. At present, only variable tracing is implemented. The
Xlegal \fIoption\fR's (which may be abbreviated) are:
X.RS
X.TP
X\fBtrace variable \fIname ops command\fR
XArrange for \fIcommand\fR to be executed whenever variable \fIname\fR
Xis accessed in one of the ways given by \fIops\fR. \fIName\fR may
Xrefer to a normal variable, an element of an array, or to an array
Xas a whole (i.e. \fIname\fR may be just the name of an array, with no
Xparenthesized index). If \fIname\fR refers to a whole array, then
X\fIcommand\fR is invoked whenever any element of the array is
Xmanipulated.
X.RS
X.LP
X\fIOps\fR indicates which operations are of interest, and consists of
Xone or more of the following letters:
X.RS
X.TP
X\fBr\fR
XInvoke \fIcommand\fR whenever the variable is read.
X.TP
X\fBw\fR
XInvoke \fIcommand\fR whenever the variable is written.
X.TP
X\fBu\fR
XInvoke \fIcommand\fR whenever the variable is unset. Variables
Xcan be unset explicitly with the \fBunset\fR command, or
Ximplicitly when procedures return (all of their local variables
Xare unset). Variables are also unset when interpreters are
Xdeleted, but traces will not be invoked because there is no
Xinterpreter in which to execute them.
X.RE
X.LP
XWhen the trace triggers, three arguments are appended to
X\fIcommand\fR so that the actual command is as follows:
X.DS C
X\fIcommand name1 name2 op\fR
X.DE
X\fIName1\fR and \fIname2\fR give the name(s) for the variable
Xbeing accessed: if the variable is a scalar then \fIname1\fR
Xgives the variable's name and \fIname2\fR is an empty string;
Xif the variable is an array element then \fIname1\fR gives the
Xname of the array and name2 gives the index into the array;
Xif an entire array is being deleted and the trace was registered
Xon the overall array, rather than a single element, then \fIname1\fR
Xgives the array name and \fIname2\fR is an empty string.
X\fIOp\fR indicates what operation is being performed on the
Xvariable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as
Xdefined above.
X.LP
X\fICommand\fR executes in the same context as the code that invoked
Xthe traced operation: if the variable was accessed as part of a
XTcl procedure, then \fIcommand\fR will have access to the same
Xlocal variables as code in the procedure. This context may be
Xdifferent than the context in which the trace was created.
XNote that \fIname1\fR may not necessarily be the same as the name
Xused to set the trace on the variable; differences can occur if
Xthe access is made through a variable defined with the \fBupvar\fR
Xcommand.
X.LP
XFor read and write traces, \fIcommand\fR can modify
Xthe variable to affect the result of the traced operation.
XIf \fIcommand\fR modifies the value of a variable during a
Xread trace, then the value returned by the traced read operation
Xwill be the value of the variable after \fIcommand\fR completes.
XFor write traces, \fIcommand\fR is invoked after the variable's
Xvalue has been changed; it can write a new value into the variable
Xto override the original value specified in the write operation.
XThe value returned by the traced write operation will be the
Xvalue of the variable when \fIcommand\fR completes.
XIf \fIcommand\fR returns an error during a read or write trace,
Xthen the traced operation is aborted with an error.
XThis mechanism can be used to implement read-only variables,
Xfor example.
X\fICommand\fR's result is always ignored.
X.LP
XWhile \fIcommand\fR is executing during a read or write trace, traces
Xon the variable are temporarily disabled.
XThis means that reads and writes invoked by
X\fIcommand\fR will occur directly, without invoking \fIcommand\fR
X(or any other traces) again.
XIt is illegal to \fBunset\fR a variable while a trace
Xis active for it.
XIt is also illegal to \fBunset\fR an array if there are
Xtraces active for any of the array's elements.
X.LP
XWhen an unset trace is invoked, the variable has already been
Xdeleted: it will appear to be undefined with no traces.
XIf an unset occurs because of a procedure return, then the
Xtrace will be invoked in the variable context of the procedure
Xbeing returned to: the stack frame of the returning procedure
Xwill no longer exist.
XTraces are not disabled during unset traces, so if an unset trace
Xcommand creates a new trace and accesses the variable, the
Xtrace will be invoked.
X.LP
XIf there are multiple traces on a variable they are invoked
Xin order of creation, most-recent first.
XIf one trace returns an error, then no further traces are
Xinvoked for the variable.
XIf an array element has a trace set, and there is also a trace
Xset on the array as a whole, the trace on the overall array
Xis invoked before the one on the element.
X.LP
XOnce created, the trace remains in effect either until the
Xtrace is removed with the \fBtrace vdelete\fR command described
Xbelow, until the variable is unset, or until the interpreter
Xis deleted.
XUnsetting an element of array will remove any traces on that
Xelement, but will not remove traces on the overall array.
X.LP
XThis command returns an empty string.
X.RE
X.TP
X\fBtrace vdelete \fIname ops command\fR
XIf there is a trace set on variable \fIname\fR with the
Xoperations and command given by \fIops\fR and \fIcommand\fR,
Xthen the trace is removed, so that \fIcommand\fR will never
Xagain be invoked.
XReturns an empty string.
X.TP
X\fBtrace vinfo \fIname\fR
XReturns a list containing one element for each trace
Xcurrently set on variable \fIname\fR.
XEach element of the list is itself a list containing two
Xelements, which are the \fIops\fR and \fIcommand\fR associated
Xwith the trace.
XIf \fIname\fR doesn't exist or doesn't have any traces set, then
Xthe result of the command will be an empty string.
X.RE
X.TP
X\fBunknown \fIcmdName \fR?\fIarg arg ...\fR?
XThis command doesn't actually exist as part of Tcl, but Tcl will
Xinvoke it if it does exist.
XIf the Tcl interpreter encounters a command name for which there
Xis not a defined command, then Tcl checks for the existence of
Xa command named \fBunknown\fR.
XIf there is no such command, then the interpeter returns an
Xerror.
XIf the \fBunknown\fR command exists, then it is invoked with
Xarguments consisting of the fully-substituted name and arguments
Xfor the original non-existent command.
XThe \fBunknown\fR command typically does things like searching
Xthrough library directories for a command procedure with the name
X\fIcmdName\fR, or expanding abbreviated command names to full-length,
Xor automatically executing unknown commands as UNIX sub-processes.
XIn some cases (such as expanding abbreviations) \fBunknown\fR will
Xchange the original command slightly and then (re-)execute it.
XThe result of the \fBunknown\fR command is used as the result for
Xthe original non-existent command.
X.TP
X\fBunset \fIname \fR?\fIname name ...\fR?
XRemove one or more variables.
XEach \fIname\fR is a variable name, specified in any of the
Xways acceptable to the \fBset\fR command.
XIf a \fIname\fR refers to an element of an array, then that
Xelement is removed without affecting the rest of the array.
XIf a \fIname\fR consists of an array name with no parenthesized
Xindex, then the entire array is deleted.
XThe \fBunset\fR command returns an empty string as result.
XAn error occurs if any of the variables doesn't exist, or if
Xany of the variables has an active trace.
X.VE
X.TP
X\fBuplevel \fR?\fIlevel\fR?\fI command \fR?\fIcommand ...\fR?
XAll of the \fIcommand\fR arguments are concatenated as if they had
Xbeen passed to \fBconcat\fR; the result is then evaluated in the
Xvariable context indicated by \fIlevel\fR. \fBUplevel\fR returns
Xthe result of that evaluation. If \fIlevel\fR is an integer, then
Xit gives a distance (up the procedure calling stack) to move before
Xexecuting the command. If \fIlevel\fR consists of \fB#\fR followed by
Xa number then the number gives an absolute level number. If \fIlevel\fR
Xis omitted then it defaults to \fB1\fR. \fILevel\fR cannot be
Xdefaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR.
XFor example, suppose that procedure \fBa\fR was invoked
Xfrom top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR.
XSuppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR
Xis \fB1\fR or \fB#2\fR or omitted, then the command will be executed
Xin the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR
Xthen the command will be executed in the variable context of \fBa\fR.
XIf \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed
Xat top-level (only global variables will be visible).
XThe \fBuplevel\fR command causes the invoking procedure to disappear
Xfrom the procedure calling stack while the command is being executed.
XIn the above example, suppose \fBc\fR invokes the command
X.RS
X.DS
X\fBuplevel 1 {set x 43; d}
X.DE
Xwhere \fBd\fR is another Tcl procedure. The \fBset\fR command will
Xmodify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute
Xat level 3, as if called from \fBb\fR. If it in turn executes
Xthe command
X.DS
X\fBuplevel {set x 42}
X.DE
Xthen the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's
Xcontext: the procedure \fBc\fR does not appear to be on the call stack
Xwhen \fBd\fR is executing. The command ``\fBinfo level\fR'' may
Xbe used to obtain the level of the current procedure.
X\fBUplevel\fR makes it possible to implement new control
Xconstructs as Tcl procedures (for example, \fBuplevel\fR could
Xbe used to implement the \fBwhile\fR construct as a Tcl procedure).
X.RE
X.TP
X\fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...?
X.VS
XThis command arranges for one or more local variables in the current
Xprocedure to refer to variables in an enclosing procedure call or
Xto global variables.
X\fILevel\fR may have any of the forms permitted for the \fBuplevel\fR
Xcommand, and may be omitted if the first letter of the first \fIotherVar\fR
Xisn't \fB#\fR or a digit (it defaults to \fB1\fR).
XFor each \fIotherVar\fR argument, \fBupvar\fR makes the variable
Xby that name in the procedure frame given by \fIlevel\fR (or at
Xglobal level, if \fIlevel\fR is \fB#0\fR) accessible
Xin the current procedure by the name given in the corresponding
X\fImyVar\fR argument.
XThe variable named by \fIotherVar\fR need not exist at the time of the
Xcall; it will be created the first time \fImyVar\fR is referenced, just like
Xan ordinary variable.
X\fBUpvar\fR may only be invoked from within procedures.
XNeither \fIotherVar\fR or \fImyVar\fR may refer to an element of an
Xarray.
X\fBUpvar\fR returns an empty string.
X.RS
X.LP
XThe \fBupvar\fR command simplifies the implementation of call-by-name
Xprocedure calling and also makes it easier to build new control constructs
Xas Tcl procedures.
XFor example, consider the following procedure:
X.DS
X.ta 1c 2c 3c
X\fBproc add2 name {
X upvar $name x
X set x [expr $x+2]
X}
X.DE
X\fBAdd2\fR is invoked with an argument giving the name of a variable,
Xand it adds two to the value of that variable.
XAlthough \fBadd2\fR could have been implemented using \fBuplevel\fR
Xinstead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR
Xto access the variable in the caller's procedure frame.
X.VE
X.RE
X.TP
X\fBwhile \fItest body
X.VS
XThe \fIwhile\fR command evaluates \fItest\fR as an expression
X(in the same way that \fBexpr\fR evaluates its argument).
XThe value of the expression must be numeric; if it is non-zero
Xthen \fIbody\fR is executed by passing it to the Tcl interpreter.
XOnce \fIbody\fR has been executed then \fItest\fR is evaluated
Xagain, and the process repeats until eventually \fItest\fR
Xevaluates to a zero numeric value. \fBContinue\fR
Xcommands may be executed inside \fIbody\fR to terminate the current
Xiteration of the loop, and \fBbreak\fR
Xcommands may be executed inside \fIbody\fR to cause immediate
Xtermination of the \fBwhile\fR command. The \fBwhile\fR command
Xalways returns an empty string.
X.VE
X
X.SH "BUILT-IN VARIABLES"
X.PP
XThe following global variables are created and managed automatically
Xby the Tcl library. Except where noted below, these variables should
Xnormally be treated as read-only by application-specific code and by users.
X.TP
X\fBenv\fR
X.br
X.VS
XThis variable is maintained by Tcl as an array
Xwhose elements are the environment variables for the process.
XReading an element will return the value of the corresponding
Xenvironment variable.
XSetting an element of the array will modify the corresponding
Xenvironment variable or create a new one if it doesn't already
Xexist.
XUnsetting an element of \fBenv\fR will remove the corresponding
Xenvironment variable.
XChanges to the \fBenv\fR array will affect the environment
Xpassed to children by commands like \fBexec\fR.
XIf the entire \fBenv\fR array is unset then Tcl will stop
Xmonitoring \fBenv\fR accesses and will not update environment
Xvariables.
X.TP
X\fBerrorCode\fR
XAfter an error has occurred, this variable will be set to hold
Xadditional information about the error in a form that is easy
Xto process with programs.
X\fBerrorCode\fR consists of a Tcl list with one or more elements.
XThe first element of the list identifies a general class of
Xerrors, and determines the format of the rest of the list.
XThe following formats for \fBerrorCode\fR are used by the
XTcl core; individual applications may define additional formats.
X.RS
X.TP
X\fBCHILDKILLED\fI pid sigName msg\fR
XThis format is used when a child process has been killed because of
Xa signal. The second element of \fBerrorCode\fR will be the
Xprocess's identifier (in decimal).
XThe third element will be the symbolic name of the signal that caused
Xthe process to terminate; it will be one of the names from the
Xinclude file signal.h, such as \fBSIGPIPE\fR.
XThe fourth element will be a short human-readable message
Xdescribing the signal, such as ``write on pipe with no readers''
Xfor \fBSIGPIPE\fR.
X.TP
X\fBCHILDSTATUS\fI pid code\fR
XThis format is used when a child process has exited with a non-zero
Xexit status. The second element of \fBerrorCode\fR will be the
Xprocess's identifier (in decimal) and the third element will be the exit
Xcode returned by the process (also in decimal).
X.TP
X\fBCHILDSUSP\fI pid code\fR
XThis format is used when a child process has been suspended because
Xof a signal.
XThe second element of \fBerrorCode\fR will be the process's identifier,
Xin decimal.
XThe third element will be the symbolic name of the signal that caused
Xthe process to suspend; this will be one of the names from the
Xinclude file signal.h, such as \fBSIGTTIN\fR.
XThe fourth element will be a short human-readable message
Xdescribing the signal, such as ``background tty read''
Xfor \fBSIGTTIN\fR.
X.TP
X\fBNONE\fR
X.br
XThis format is used for errors where no additional information is
Xavailable for an error besides the message returned with the
Xerror. In these cases \fBerrorCode\fR will consist of a list
Xcontaining a single element whose contents are \fBNONE\fR.
X.TP
X\fBUNIX \fIerrName msg\fR
XIf the first element of \fBerrorCode\fR is \fBUNIX\fR, then
Xthe error occurred during a UNIX kernel call.
XThe second element of the list will contain the symbolic name
Xof the error that occurred, such as \fBENOENT\fR; this will
Xbe one of the values defined in the include file errno.h.
XThe third element of the list will be a human-readable
Xmessage corresponding to \fIerrName\fR, such as
X``no such file or directory'' for the \fBENOENT\fR case.
X.PP
XTo set \fBerrorCode\fR, applications should use library
Xprocedures such as \fBTcl_SetErrorCode\fR and
X\fBTcl_UnixError\fR, or they may invoke the \fBerror\fR command.
XIf one of these methods hasn't been used, then the Tcl
Xinterpreter will reset the variable to \fBNONE\fR after
Xthe next error.
X.RE
X.VE
X.TP
X\fBerrorInfo\fR
XAfter an error has occurred, this string will contain one or more lines
Xidentifying the Tcl commands and procedures that were being executed
Xwhen the most recent error occurred.
XIts contents take the form of a stack trace showing the various
Xnested Tcl commands that had been invoked at the time of the error.
X
X.SH AUTHOR
XJohn Ousterhout, University of California at Berkeley (ous...@sprite.berkeley.edu)
X.sp
XMany people have contributed to Tcl in various ways, but the following
Xpeople have made unusually large contributions:
X.sp
X.nf
XBill Carpenter
XPeter Da Silva
XMark Diekhans
XKarl Lehenbauer
XMary Ann May-Pumphrey
END_OF_FILE
if test 41512 -ne `wc -c <'tcl6.1/doc/Tcl.man.3'`; then
echo shar: \"'tcl6.1/doc/Tcl.man.3'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Tcl.man.3'
fi
echo shar: End of archive 32 $of 33$.
cp /dev/null ark32isdone

Karl Lehenbauer

unread,

Nov 15, 1991, 6:01:49 PM11/15/91

Submitted-by: ka...@sugar.neosoft.com (Karl Lehenbauer)
Posting-number: Volume 25, Issue 101
Archive-name: tcl/part33
Environment: UNIX

# "End of archive 33 (of 33)."
# Contents: tcl6.1/doc/Tcl.man.2
# Wrapped by karl@one on Tue Nov 12 19:44:34 1991

PATH=/bin:/usr/bin:/usr/ucb ; export PATH

if test -f 'tcl6.1/doc/Tcl.man.2' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'tcl6.1/doc/Tcl.man.2'\"
else
echo shar: Extracting \"'tcl6.1/doc/Tcl.man.2'\" $41756 characters$
sed "s/^X//" >'tcl6.1/doc/Tcl.man.2' <<'END_OF_FILE'
X.PP
XIf a regular expression could match two different parts of a string,
Xit will match the one which begins earliest.
XIf both begin in the same place but match different lengths, or match
Xthe same length in different ways, life gets messier, as follows.
X.PP
XIn general, the possibilities in a list of branches are considered in
Xleft-to-right order, the possibilities for ``*'', ``+'', and ``?'' are
Xconsidered longest-first, nested constructs are considered from the
Xoutermost in, and concatenated constructs are considered leftmost-first.
XThe match that will be chosen is the one that uses the earliest
Xpossibility in the first choice that has to be made.
XIf there is more than one choice, the next will be made in the same manner
X(earliest possibility) subject to the decision on the first choice.
XAnd so forth.
X.PP
XFor example, ``(ab|a)b*c'' could match ``abc'' in one of two ways.
XThe first choice is between ``ab'' and ``a''; since ``ab'' is earlier, and does
Xlead to a successful overall match, it is chosen.
XSince the ``b'' is already spoken for,
Xthe ``b*'' must match its last possibility\(emthe empty string\(emsince
Xit must respect the earlier choice.
X.PP
XIn the particular case where no ``|''s are present and there is only one
X``*'', ``+'', or ``?'', the net effect is that the longest possible
Xmatch will be chosen.
XSo ``ab*'', presented with ``xabbbby'', will match ``abbbb''.
XNote that if ``ab*'' is tried against ``xabyabbbz'', it
Xwill match ``ab'' just after ``x'', due to the begins-earliest rule.
X(In effect, the decision on where to start the match is the first choice
Xto be made, hence subsequent choices must respect it even if this leads them
Xto less-preferred alternatives.)
X.VE
X
X.SH "COMMAND RESULTS"
X.PP
XEach command produces two results: a code and a string. The
Xcode indicates whether the command completed successfully or not,
Xand the string gives additional information. The valid codes are
Xdefined in tcl.h, and are:
X.RS
X.TP 20
X\fBTCL_OK\fR
XThis is the normal return code, and indicates that the command completed
Xsuccessfully. The string gives the command's return value.
X.TP 20
X\fBTCL_ERROR\fR
XIndicates that an error occurred; the string gives a message describing
Xthe error.
X.VS
XIn additon, the global variable \fBerrorInfo\fR will contain
Xhuman-readable information
Xdescribing which commands and procedures were being executed when the
Xerror occurred, and the global variable \fBerrorCode\fR will contain
Xmachine-readable details about the error, if they are available.
XSee the section BUILT-IN VARIABLES below for more information.
X.VE
X.VE
X.TP 20
X\fBTCL_RETURN\fR
XIndicates that the \fBreturn\fR command has been invoked, and that the
Xcurrent procedure (or top-level command or \fBsource\fR command)
Xshould return immediately. The
Xstring gives the return value for the procedure or command.
X.TP 20
X\fBTCL_BREAK\fR
XIndicates that the \fBbreak\fR command has been invoked, so the
Xinnermost loop should abort immediately. The string should always
Xbe empty.
X.TP 20
X\fBTCL_CONTINUE\fR
XIndicates that the \fBcontinue\fR command has been invoked, so the
Xinnermost loop should go on to the next iteration. The string
Xshould always be empty.
X.RE
XTcl programmers do not normally need to think about return codes,
Xsince TCL_OK is almost always returned. If anything else is returned
Xby a command, then the Tcl interpreter immediately stops processing
Xcommands and returns to its caller. If there are several nested
Xinvocations of the Tcl interpreter in progress, then each nested
Xcommand will usually return the error to its caller, until eventually
Xthe error is reported to the top-level application code. The
Xapplication will then display the error message for the user.
X.PP
XIn a few cases, some commands will handle certain ``error'' conditions
Xthemselves and not return them upwards. For example, the \fBfor\fR
Xcommand checks for the TCL_BREAK code; if it occurs, then \fBfor\fR
Xstops executing the body of the loop and returns TCL_OK to its
Xcaller. The \fBfor\fR command also handles TCL_CONTINUE codes and the
Xprocedure interpreter handles TCL_RETURN codes. The \fBcatch\fR
Xcommand allows Tcl programs to catch errors and handle them without
Xaborting command interpretation any further.
X
X.SH PROCEDURES
X.PP
XTcl allows you to extend the command interface by defining
Xprocedures. A Tcl procedure can be invoked just like any other Tcl
Xcommand (it has a name and it receives one or more arguments).
XThe only difference is that its body isn't a piece of C code linked
Xinto the program; it is a string containing one or more other
XTcl commands. See the \fBproc\fR command for information on
Xhow to define procedures and what happens when they are invoked.
X
X.SH VARIABLES \- SCALARS AND ARRAYS
X.VS
X.PP
XTcl allows the definition of variables and the use of their values
Xeither through \fB$\fR-style variable substitution, the \fBset\fR
Xcommand, or a few other mechanisms.
XVariables need not be declared: a new variable will automatically
Xbe created each time a new variable name is used.
X.PP
XTcl supports two types of variables: scalars and arrays.
XA scalar variable has a single value, whereas an array variable
Xcan have any number of elements, each with a name (called
Xits ``index'') and a value.
XArray indexes may be arbitrary strings; they need not be numeric.
XParentheses are used refer to array elements in Tcl commands.
XFor example, the command
X.DS C
X\fBset x(first) 44\fR
X.DE
Xwill modify the element of \fBx\fR whose index is \fBfirst\fR
Xso that its new value is \fB44\fR.
XTwo-dimensional arrays can be simulated in Tcl by using indexes
Xthat contain multiple concatenated values.
XFor example, the commands
X.DS C
X\fBset a(2,3) 1\fR
X\fBset a(3,6) 2\fR
X.DE
Xset the elements of \fBa\fR whose indexes are \fB2,3\fR and \fB3,6\fR.
X.PP
XIn general, array elements may be used anywhere in Tcl that scalar
Xvariables may be used.
XIf an array is defined with a particular name, then there may
Xnot be a scalar variable with the same name.
XSimilarly, if there is a scalar variable with a particular
Xname then it is not possible to make array references to the
Xvariable.
XTo convert a scalar variable to an array or vice versa, remove
Xthe existing variable with the \fBunset\fR command.
X.PP
XThe \fBarray\fR command provides several features for dealing
Xwith arrays, such as querying the names of all the elements of
Xthe array and searching through the array one element at a time.
X.VE
X.PP
XVariables may be either global or local. If a variable
Xname is used when a procedure isn't being executed, then it
Xautomatically refers to a global variable. Variable names used
Xwithin a procedure normally refer to local variables associated with that
Xinvocation of the procedure. Local variables are deleted whenever
Xa procedure exits. The \fBglobal\fR command may be used to request
Xthat a name refer to a global variable for the duration of the current
Xprocedure (this is somewhat analogous to \fBextern\fR in C).
X
X.SH "BUILT-IN COMMANDS"
X.PP
XThe Tcl library provides the following built-in commands, which will
Xbe available in any application using Tcl. In addition to these
Xbuilt-in commands, there may be additional commands defined by each
Xapplication, plus commands defined as Tcl procedures.
XIn the command syntax descriptions below, words in boldface are
Xliterals that you type verbatim to Tcl.
XWords in italics are meta-symbols; they serve as names for any of
Xa range of values that you can type.
XOptional arguments or groups of arguments are indicated by enclosing them
Xin question-marks.
XEllipses (``...'') indicate that any number of additional
Xarguments or groups of arguments may appear, in the same format
Xas the preceding argument(s).
X.TP
X\fBappend \fIvarName value \fR?\fIvalue value ...\fR?
X.VS
XAppend all of the \fIvalue\fR arguments to the current value
Xof variable \fIvarName\fR. If \fIvarName\fR doesn't exist,
Xit is given a value equal to the concatenation of all the
X\fIvalue\fR arguments.
XThis command provides an efficient way to build up long
Xvariables incrementally.
XFor example, ``\fBappend a $b\fR'' is much more efficient than
X``\fBset a $a$b\fR'' if \fB$a\fR is long.
X.VE
X.TP
X\fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR?
X.VS
XThis command performs one of several operations on the
Xvariable given by \fIarrayName\fR.
X\fIArrayName\fR must be the name of an existing array variable.
XThe \fIoption\fR argument determines what action is carried
Xout by the command.
XThe legal \fIoptions\fR (which may be abbreviated) are:
X.RS
X.TP
X\fBarray anymore \fIarrayName searchId\fR
XReturns 1 if there are any more elements left to be processed
Xin an array search, 0 if all elements have already been
Xreturned.
X\fISearchId\fR indicates which search on \fIarrayName\fR to
Xcheck, and must have been the return value from a previous
Xinvocation of \fBarray startsearch\fR.
XThis option is particularly useful if an array has an element
Xwith an empty name, since the return value from
X\fBarray nextelement\fR won't indicate whether the search
Xhas been completed.
X.TP
X\fBarray donesearch \fIarrayName searchId\fR
XThis command terminates an array search and destroys all the
Xstate associated with that search. \fISearchId\fR indicates
Xwhich search on \fIarrayName\fR to destroy, and must have
Xbeen the return value from a previous invocation of
X\fBarray startsearch\fR. Returns an empty string.
X.TP
X\fBarray names \fIarrayName\fR
XReturns a list containing the names of all of the elements in
Xthe array.
XIf there are no elements in the array then an empty string is
Xreturned.
X.TP
X\fBarray nextelement \fIarrayName searchId\fR
XReturns the name of the next element in \fIarrayName\fR, or
Xan empty string if all elements of \fIarrayName\fR have
Xalready been returned in this search. The \fIsearchId\fR
Xargument identifies the search, and must have
Xbeen the return value of an \fBarray startsearch\fR command.
XWarning: if elements are added to or deleted from the array,
Xthen all searches are automatically terminated just as if
X\fBarray donesearch\fR had been invoked; this will cause
X\fBarray nextelement\fR operations to fail for those searches.
X.TP
X\fBarray size \fIarrayName\fR
XReturns a decimal string giving the number of elements in the
Xarray.
X.TP
X\fBarray startsearch \fIarrayName\fR
XThis command initializes an element-by-element search through the
Xarray given by \fIarrayName\fR, such that invocations of the
X\fBarray nextelement\fR command will return the names of the
Xindividual elements in the array.
XWhen the search has been completed, the \fBarray donesearch\fR
Xcommand should be invoked.
XThe return value is a
Xsearch identifier that must be used in \fBarray nextelement\fR
Xand \fBarray donesearch\fR commands; it allows multiple
Xsearches to be underway simultaneously for the same array.
X.VE
X.RE
X.TP
X\fBbreak\fR
XThis command may be invoked only inside the body of a loop command
Xsuch as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. It returns a TCL_BREAK code
Xto signal the innermost containing loop command to return immediately.
X.TP
X\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...?
X.TP
X\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?}
XMatch \fIstring\fR against each of the \fIpatList\fR arguments
Xin order. If one matches, then evaluate the following \fIbody\fR argument
Xby passing it recursively to the Tcl interpreter, and return the result
Xof that evaluation. Each \fIpatList\fR argument consists of a single
Xpattern or list of patterns. Each pattern may contain any of the wild-cards
Xdescribed under \fBstring match\fR. If a \fIpatList\fR
Xargument is \fBdefault\fR, the corresponding body will be evaluated
Xif no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument
Xmatches \fIstring\fR and no default is given, then the \fBcase\fR
Xcommand returns an empty string.
X.RS
X.PP
XTwo syntaxes are provided.
XThe first uses a separate argument for each of the patterns and commands;
Xthis form is convenient if substitutions are desired on some of the
Xpatterns or commands.
X.VS
XThe second form places all of the patterns and commands together into
Xa single argument; the argument must have proper list structure, with
Xthe elements of the list being the patterns and commands.
XThe second form makes it easy to construct multi-line case commands,
Xsince the braces around the whole list make it unnecessary to include a
Xbackslash at the end of each line.
XSince the \fIpatList\fR arguments are in braces in the second form,
Xno command or variable substitutions are performed on them; this makes
Xthe behavior of the second form different than the first form in some
Xcases.
X.PP
XBelow are some examples of \fBcase\fR commands:
X.DS
X\fBcase abc in {a b} {format 1} default {format 2} a* {format 3}
X.DE
Xwill return \fB3\fR,
X.DS
X.ta .5c 1c
X\fBcase a in {
X {a b} {format 1}
X default {format 2}
X a* {format 3}
X}
X.DE
Xwill return \fB1\fR, and
X.DS
X.ta .5c 1c
X\fBcase xyz {
X {a b}
X {format 1}
X default
X {format 2}
X a*
X {format 3}
X}
X.DE
Xwill return \fB2\fR.
X.VE
X.RE
X.TP
X\fBcatch\fI command \fR?\fIvarName\fR?
XThe \fBcatch\fR command may be used to prevent errors from aborting
Xcommand interpretation. \fBCatch\fR calls the Tcl interpreter recursively
Xto execute \fIcommand\fR, and always returns a TCL_OK code, regardless of
Xany errors that might occur while executing \fIcommand\fR. The return
Xvalue from \fBcatch\fR is a decimal string giving the
Xcode returned by the Tcl interpreter after executing \fIcommand\fR.
XThis will be \fB0\fR (TCL_OK) if there were no errors in \fIcommand\fR; otherwise
Xit will have a non-zero value corresponding to one of the exceptional
Xreturn codes (see tcl.h for the definitions of code values). If the
X\fIvarName\fR argument is given, then it gives the name of a variable;
X\fBcatch\fR will set the value of the variable to the string returned
Xfrom \fIcommand\fR (either a result or an error message).
X.TP
X\fBcd \fR?\fIdirName\fR?
X.VS
XChange the current working directory to \fIdirName\fR, or to the
Xhome directory (as specified in the HOME environment variable) if
X\fIdirName\fR is not given.
XIf \fIdirName\fR starts with a tilde, then tilde-expansion is
Xdone as described for \fBTcl_TildeSubst\fR.
XReturns an empty string.
XThis command can potentially be disruptive to an application,
Xso it may be removed in some applications.
X.TP
X\fBclose \fIfileId\fR
XCloses the file given by \fIfileId\fR.
X\fIFileId\fR must be the return value from a previous invocation
Xof the \fBopen\fR command; after this command, it should not be
Xused anymore.
XIf \fIfileId\fR refers to a command pipeline instead of a file,
Xthen \fBclose\fR waits for the children to complete.
XThe normal result of this command is an empty string, but errors
Xare returned if there are problems in closing the file or waiting
Xfor children to complete.
X.VE
X.TP
X\fBconcat\fI arg \fR?\fIarg ...\fR?
XThis command treats each argument as a list and concatenates them
Xinto a single list. It permits any number of arguments. For example,
Xthe command
X.RS
X.DS
X\fBconcat a b {c d e} {f {g h}}\fR
X.DE
Xwill return
X.DS
X\fBa b c d e f {g h}\fR
X.DE
Xas its result.
X.RE
X.TP
X\fBcontinue\fR
XThis command may be invoked only inside the body of a loop command
Xsuch as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. It
Xreturns a TCL_CONTINUE code
Xto signal the innermost containing loop command to skip the
Xremainder of the loop's body
Xbut continue with the next iteration of the loop.
X.TP
X\fBeof \fIfileId\fR
X.VS
XReturns 1 if an end-of-file condition has occurred on \fIfileId\fR,
X0 otherwise.

X\fIFileId\fR must have been the return
Xvalue from a previous call to \fBopen\fR, or it may be \fBstdin\fR,
X\fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O
Xchannels.
X.VE
X.TP

X\fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR?
XReturns a TCL_ERROR code, which causes command interpretation to be
Xunwound. \fIMessage\fR is a string that is returned to the application
Xto indicate what went wrong.
X.RS
X.PP
XIf the \fIinfo\fR argument is provided and is non-empty,
Xit is used to initialize the global variable \fBerrorInfo\fR.
X\fBerrorInfo\fR is used to accumulate a stack trace of what
Xwas in progress when an error occurred; as nested commands unwind,
Xthe Tcl interpreter adds information to \fBerrorInfo\fR. If the
X\fIinfo\fR argument is present, it is used to initialize
X\fBerrorInfo\fR and the first increment of unwind information
Xwill not be added by the Tcl interpreter. In other
Xwords, the command containing the \fBerror\fR command will not appear
Xin \fBerrorInfo\fR; in its place will be \fIinfo\fR.
XThis feature is most useful in conjunction with the \fBcatch\fR command:
Xif a caught error cannot be handled successfully, \fIinfo\fR can be used
Xto return a stack trace reflecting the original point of occurrence
Xof the error:
X.DS
X\fBcatch {...} errMsg
Xset savedInfo $errorInfo
X\&...
Xerror $errMsg $savedInfo\fR
X.DE
X.PP
X.VS
XIf the \fIcode\fR argument is present, then its value is stored
Xin the \fBerrorCode\fR global variable. This variable is intended
Xto hold a machine-readable description of the error in cases where
Xsuch information is available; see the section BUILT-IN VARIABLES
Xbelow for information on the proper format for the variable.
XIf the \fIcode\fR argument is not
Xpresent, then \fBerrorCode\fR is automatically reset to
X``NONE'' by the Tcl interpreter as part of processing the
Xerror generated by the command.
X.VE
X.RE
X.TP
X\fBeval \fIarg \fR?\fIarg ...\fR?
X\fBEval\fR takes one or more arguments, which together comprise a Tcl
Xcommand (or collection of Tcl commands separated by newlines in the
Xusual way). \fBEval\fR concatenates all its arguments in the same
Xfashion as the \fBconcat\fR command, passes the concatenated string to the
XTcl interpreter recursively, and returns the result of that
Xevaluation (or any error generated by it).
X.TP
X\fBexec \fIarg \fR?\fIarg ...\fR?
X.VS
XThis command treats its arguments as the specification
Xof one or more UNIX commands to execute as subprocesses.
XThe commands take the form of a standard shell pipeline;
X``|'' arguments separate commands in the
Xpipeline and cause standard output of the preceding command
Xto be piped into standard input of the next command.
X.RS
X.PP
XUnder normal conditions the result of the \fBexec\fR command
Xconsists of the standard output produced by the last command
Xin the pipeline.
XIf any of the commands in the pipeline exit abnormally or
Xare killed or suspended, then \fBexec\fR will return an error
Xand the error message will include the pipeline's output followed by
Xerror messages describing the abnormal terminations; the
X\fBerrorCode\fR variable will contain additional information
Xabout the last abnormal termination encountered.
XIf any of the commands writes to its standard error file,
Xthen \fBexec\fR will return an error, and the error message
Xwill include the pipeline's output, followed by messages
Xabout abnormal terminations (if any), followed by the standard error
Xoutput.
X.PP
XIf the last character of the result or error message
Xis a newline then that character is deleted from the result
Xor error message for consistency with normal
XTcl return values.
X.PP
XIf an \fIarg\fR has the value ``>'' then the
Xfollowing argument is taken as the name of a file and
Xthe standard output of the last command in the pipeline
Xis redirected to the file. In this situation \fBexec\fR
Xwill normally return an empty string.
X.PP
XIf an \fIarg\fR has the value ``<'' then the following
Xargument is taken as the name of a file to use
Xfor standard input to the first command in the
Xpipeline.
XIf an argument has the value ``<<'' then the following
Xargument is taken as an immediate value to be passed to
Xthe first command as standard input.
XIf there is no ``<'' or ``<<'' argument then the standard
Xinput for the first command in the pipeline is taken from
Xthe application's current standard input.
X.PP
XIf the last \fIarg\fR is ``&'' then the command will be
Xexecuted in background.
XIn this case the standard output from the last command
Xin the pipeline will
Xgo to the application's standard output unless
Xredirected in the command, and error output from all
Xthe commands in the pipeline will go to the application's
Xstandard error file.
X.PP
XEach \fIarg\fR becomes one word for a command, except for
X``|'', ``<'', ``<<'', ``>'', and ``&'' arguments, and the
Xarguments that follow ``<'', ``<<'', and ``>''.
XThe first word in each command is taken as the command name;
Xtilde-substitution is performed on it, and the directories
Xin the PATH environment variable are searched for
Xan executable by the given name.
XNo ``glob'' expansion or other shell-like substitutions
Xare performed on the arguments to commands.
X.RE
X.TP
X\fBexit \fR?returnCode\fR?
XTerminate the process, returning \fIreturnCode\fR to the
Xparent as the exit status.
XIf \fIreturnCode\fR isn't specified then it defaults
Xto 0.
X.VE
X.TP
X\fBexpr \fIarg\fR
XCalls the expression processor to evaluate \fIarg\fR, and returns
Xthe result as a string. See the section EXPRESSIONS above.
X.TP
X\fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR?
X.VS
XOperate on a file or a file name. \fIName\fR is the name of a file;
Xif it starts with a tilde, then tilde substitution is done before
Xexecuting the command (see the manual entry for \fBTcl_TildeSubst\fR
Xfor details).
X\fIOption\fR indicates what to do with the file name. Any unique
Xabbreviation for \fIoption\fR is acceptable. The valid options are:
X.RS
X.TP
X\fBfile \fBatime \fIname\fR
XReturn a decimal string giving the time at which file \fIname\fR
Xwas last accessed. The time is measured in the standard UNIX
Xfashion as seconds from a fixed starting time (often January 1, 1970).
XIf the file doesn't exist or its access time cannot be queried then an
Xerror is generated.
X.TP
X\fBfile \fBdirname \fIname\fR
XReturn all of the characters in \fIname\fR up to but not including
Xthe last slash character. If there are no slashes in \fIname\fR
Xthen return ``.''. If the last slash in \fIname\fR is its first
Xcharacter, then return ``/''.
X.TP
X\fBfile \fBexecutable \fIname\fR
XReturn \fB1\fR if file \fIname\fR is executable by
Xthe current user, \fB0\fR otherwise.
X.TP
X\fBfile \fBexists \fIname\fR
XReturn \fB1\fR if file \fIname\fR exists and the current user has
Xsearch privileges for the directories leading to it, \fB0\fR otherwise.
X.TP
X\fBfile \fBextension \fIname\fR
XReturn all of the characters in \fIname\fR after and including the
Xlast dot in \fIname\fR. If there is no dot in \fIname\fR then return
Xthe empty string.
X.TP
X\fBfile \fBisdirectory \fIname\fR
XReturn \fB1\fR if file \fIname\fR is a directory,
X\fB0\fR otherwise.
X.TP
X\fBfile \fBisfile \fIname\fR
XReturn \fB1\fR if file \fIname\fR is a regular file,
X\fB0\fR otherwise.
X.TP
X\fBfile \fBmtime \fIname\fR
XReturn a decimal string giving the time at which file \fIname\fR
Xwas last modified. The time is measured in the standard UNIX
Xfashion as seconds from a fixed starting time (often January 1, 1970).
XIf the file doesn't exist or its modified time cannot be queried then an
Xerror is generated.
X.TP
X\fBfile \fBowned \fIname\fR
XReturn \fB1\fR if file \fIname\fR is owned by the current user,
X\fB0\fR otherwise.
X.TP
X\fBfile \fBreadable \fIname\fR
XReturn \fB1\fR if file \fIname\fR is readable by
Xthe current user, \fB0\fR otherwise.
X.TP
X\fBfile \fBrootname \fIname\fR
XReturn all of the characters in \fIname\fR up to but not including
Xthe last ``.'' character in the name. If \fIname\fR doesn't contain
Xa dot, then return \fIname\fR.
X.TP
X\fBfile \fBsize \fIname\fR
XReturn a decimal string giving the size of file \fIname\fR in bytes.
XIf the file doesn't exist or its size cannot be queried then an
Xerror is generated.
X.TP
X\fBfile \fBstat \fIname\fIvarName\fR
XInvoke the \fBstat\fR kernel call on \fIname\fR, and use the
Xvariable given by \fIvarName\fR to hold information returned from
Xthe kernel call.
X\fIVarName\fR is treated as an array variable,
Xand the following elements of that variable are set: \fBatime\fR,
X\fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR,
X\fBnlink\fR, \fBsize\fR, \fBuid\fR.
XEach element is a decimal string with the value of the corresponding
Xfield from the \fBstat\fR return structure; see the manual entry
Xfor \fBstat\fR for details on the meanings of the values.

XThis command returns an empty string.

X.TP
X\fBfile \fBtail \fIname\fR
XReturn all of the characters in \fIname\fR after the last slash.
XIf \fIname\fR contains no slashes then return \fIname\fR.
X.TP
X\fBfile \fBwritable \fIname\fR
XReturn \fB1\fR if file \fIname\fR is writable by
Xthe current user, \fB0\fR otherwise.
X.RE
X.IP
XThe \fBfile\fR commands that return 0/1 results are often used in
Xconditional or looping commands, for example:
X.RS
X.DS
X\fBif {![file exists foo]} then {error {bad file name}} else {...}\fR
X.DE
X.VE
X.RE
X.TP
X\fBflush \fIfileId\fR
X.VS
XFlushes any output that has been buffered for \fIfileId\fR.

X\fIFileId\fR must have been the return
Xvalue from a previous call to \fBopen\fR, or it may be

X\fBstdout\fR or \fBstderr\fR to access one of the standard I/O streams;
Xit must refer to a file that was opened for writing.

XThis command returns an empty string.

X.VE
X.TP
X\fBfor \fIstart test next body\fR
X\fBFor\fR is a looping command, similar in structure to the C
X\fBfor\fR statement. The \fIstart\fR, \fInext\fR, and
X\fIbody\fR arguments must be Tcl command strings, and \fItest\fR
Xis an expression string.
XThe \fBfor\fR command first invokes the Tcl interpreter to
Xexecute \fIstart\fR. Then it repeatedly evaluates \fItest\fR as
Xan expression; if the result is non-zero it invokes the Tcl
Xinterpreter on \fIbody\fR, then invokes the Tcl interpreter on \fInext\fR,
Xthen repeats the loop. The command terminates when \fItest\fR evaluates
Xto 0. If a \fBcontinue\fR command is invoked within \fIbody\fR then
Xany remaining commands in the current execution of \fIbody\fR are skipped;
Xprocessing continues by invoking the Tcl interpreter on \fInext\fR, then
Xevaluating \fItest\fR, and so on. If a \fBbreak\fR command is invoked
Xwithin \fIbody\fR
Xor \fInext\fR,
Xthen the \fBfor\fR command will
Xreturn immediately.
XThe operation of \fBbreak\fR and \fBcontinue\fR are similar to the
Xcorresponding statements in C.
X\fBFor\fR returns an empty string.
X.TP
X\fBforeach \fIvarname list body\fR
XIn this command, \fIvarname\fR is the name of a variable, \fIlist\fR
Xis a list of values to assign to \fIvarname\fR, and \fIbody\fR is a
Xcollection of Tcl commands. For each field in \fIlist\fR (in order
Xfrom left to right), \fBforeach\fR assigns the contents of the
Xfield to \fIvarname\fR (as if the \fBlindex\fR command had been used
Xto extract the field), then calls the Tcl interpreter to execute
X\fIbody\fR. The \fBbreak\fR and \fBcontinue\fR statements may be
Xinvoked inside \fIbody\fR, with the same effect as in the \fBfor\fR
Xcommand. \fBForeach\fR an empty string.
X.TP
X\fBformat \fIformatString \fR?\fIarg arg ...\fR?
XThis command generates a formatted string in the same way as the
XC \fBsprintf\fR procedure (it uses \fBsprintf\fR in its
Ximplementation). \fIFormatString\fR indicates how to format
Xthe result, using \fB%\fR fields as in \fBsprintf\fR, and the additional
Xarguments, if any, provide values to be substituted into the result.
XAll of the \fBsprintf\fR options are valid; see the \fBsprintf\fR
Xman page for details. Each \fIarg\fR must match the expected type
Xfrom the \fB%\fR field in \fIformatString\fR; the \fBformat\fR command
Xconverts each argument to the correct type (floating, integer, etc.)
Xbefore passing it to \fBsprintf\fR for formatting.
XThe only unusual conversion is for \fB%c\fR; in this case the argument
Xmust be a decimal string, which will then be converted to the corresponding
XASCII character value.
X\fBFormat\fR does backslash substitution on its \fIformatString\fR
Xargument, so backslash sequences in \fIformatString\fR will be handled
Xcorrectly even if the argument is in braces.
XThe return value from \fBformat\fR
Xis the formatted string.
X.TP
X\fBgets \fIfileId\fR ?\fIvarName\fR?
X.VS
XReads the next line from the file given by \fIfileId\fR and discards
Xthe terminating newline character.
XIf \fIvarName\fR is specified, then the line is placed in the variable
Xby that name and the return value is a count of the number of characters
Xread (not including the newline).
XIf the end of the file is reached before reading
Xany characters then \-1 is returned and \fIvarName\fR is set to an
Xempty string.
XIf \fIvarName\fR is not specified then the return value will be
Xthe line (minus the newline character) or an empty string if
Xthe end of the file is reached before reading any characters.
XAn empty string will also be returned if a line contains no characters
Xexcept the newline, so \fBeof\fR may have to be used to determine
Xwhat really happened.
XIf the last character in the file is not a newline character, then
X\fBgets\fR behaves as if there were an additional newline character
Xat the end of the file.
X\fIFileId\fR must be \fBstdin\fR or the return value from a previous
Xcall to \fBopen\fR; it must refer to a file that was opened
Xfor reading.
X.VE
X.TP
X\fBglob \fR?\fB\-nocomplain\fR? \fIfilename\fR ?\fIfilename ...\fR?
XThis command performs filename globbing, using csh rules. The returned
Xvalue from \fBglob\fR is the list of expanded filenames.
X.VS
XIf \fB\-nocomplain\fR is specified as the first argument then an empty
Xlist may be returned; otherwise an error is returned if the expanded
Xlist is empty. The \fB\-nocomplain\fR argument must be provided
Xexactly: an abbreviation will not be accepted.
X.VE
X.TP
X\fBglobal \fIvarname \fR?\fIvarname ...\fR?
XThis command is ignored unless a Tcl procedure is being interpreted.
XIf so, then it declares the given \fIvarname\fR's to be global variables
Xrather than local ones. For the duration of the current procedure
X(and only while executing in the current procedure), any reference to
Xany of the \fIvarname\fRs will be bound to a global variable instead
Xof a local one.
X.TP
X\fBhistory \fR?\fIoption\fR? ?\fIarg arg ...\fR?
XNote: this command may not be available in all Tcl-based applications.
XTypically, only those that receive command input in a typescript
Xform will support history.
XThe \fBhistory\fR command performs one of several operations related to
Xrecently-executed commands recorded in a history list. Each of
Xthese recorded commands is referred to as an ``event''. When
Xspecifying an event to the \fBhistory\fR command, the following
Xforms may be used:
X.RS
X.IP [1]
XA number: if positive, it refers to the event with
Xthat number (all events are numbered starting at 1). If the number
Xis negative, it selects an event relative to the current event
X(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and
Xso on).
X.IP [2]
XA string: selects the most recent event that matches the string.
XAn event is considered to match the string either if the string is
Xthe same as the first characters of the event, or if the string
Xmatches the event in the sense of the \fBstring match\fR command.
X.LP
XThe \fBhistory\fR command can take any of the following forms:
X.TP
X\fBhistory\fR
XSame
X.VS
Xas \fBhistory info\fR, described below.
X.VE
X.TP
X\fBhistory add\fI command \fR?\fBexec\fR?
XAdd the \fIcommand\fR argument to the history list as a new event. If
X\fBexec\fR is specified (or abbreviated) then the command is also
Xexecuted and its result is returned. If \fBexec\fR isn't specified
Xthen an empty string is returned as result.
X.TP
X\fBhistory change\fI newValue\fR ?\fIevent\fR?
XReplace the value recorded for an event with \fInewValue\fR. \fIEvent\fR
Xspecifies the event to replace, and
Xdefaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command
Xis intended for use in commands that implement new forms of history
Xsubstitution and wish to replace the current event (which invokes the
Xsubstitution) with the command created through substitution. The return
Xvalue is an empty string.
X.TP
X\fBhistory event\fR ?\fIevent\fR?
XReturns the value of the event given by \fIevent\fR. \fIEvent\fR
Xdefaults to \fB\-1\fR. This command causes history revision to occur:
Xsee below for details.
X.TP
X\fBhistory info \fR?\fIcount\fR?
XReturns a formatted string (intended for humans to read) giving
Xthe event number and contents for each of the events in the history
Xlist except the current event. If \fIcount\fR is specified
Xthen only the most recent \fIcount\fR events are returned.
X.TP
X\fBhistory keep \fIcount\fR
XThis command may be used to change the size of the history list to
X\fIcount\fR events. Initially, 20 events are retained in the history
Xlist. This command returns an empty string.
X.TP
X\fBhistory nextid\fR
XReturns the number of the next event to be recorded
Xin the history list. It is useful for things like printing the
Xevent number in command-line prompts.
X.TP
X\fBhistory redo \fR?\fIevent\fR?
XRe-execute the command indicated by \fIevent\fR and return its result.
X\fIEvent\fR defaults to \fB\-1\fR. This command results in history
Xrevision: see below for details.
X.TP
X\fBhistory substitute \fIold new \fR?\fIevent\fR?
XRetrieve the command given by \fIevent\fR
X(\fB\-1\fR by default), replace any occurrences of \fIold\fR by
X\fInew\fR in the command (only simple character equality is supported;
Xno wild cards), execute the resulting command, and return the result
Xof that execution. This command results in history
Xrevision: see below for details.
X.TP
X\fBhistory words \fIselector\fR ?\fIevent\fR?
XRetrieve from the command given by \fIevent\fR (\fB\-1\fR by default)
Xthe words given by \fIselector\fR, and return those words in a string
Xseparated by spaces. The \fBselector\fR argument has three forms.
XIf it is a single number then it selects the word given by that
Xnumber (\fB0\fR for the command name, \fB1\fR for its first argument,
Xand so on). If it consists of two numbers separated by a dash,
Xthen it selects all the arguments between those two. Otherwise
X\fBselector\fR is treated as a pattern; all words matching that
Xpattern (in the sense of \fBstring match\fR) are returned. In
Xthe numeric forms \fB$\fR may be used
Xto select the last word of a command.
XFor example, suppose the most recent command in the history list is
X.RS
X.DS
X\fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR
X.DE
XBelow are some history commands and the results they would produce:
X.DS
X.ta 4c
X.fi
X.UL Command " "
X.UL Result
X.nf
X
X\fBhistory words $ [expr $ageInMonths/12]\fR
X\fBhistory words 1-2 {%s is %d years old} Alice\fR
X\fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR
X.DE
X\fBHistory words\fR results in history revision: see below for details.
X.RE
XThe history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR,
Xand \fBwords\fR result in ``history revision''.
XWhen one of these options is invoked then the current event
Xis modified to eliminate the history command and replace it with
Xthe result of the history command.
XFor example, suppose that the most recent command in the history
Xlist is
X.DS
X\fBset a [expr $b+2]\fR
X.DE
Xand suppose that the next command invoked is one of the ones on
Xthe left side of the table below. The command actually recorded in
Xthe history event will be the corresponding one on the right side
Xof the table.
X.ne 1.5c
X.DS
X.ta 4c
X.fi
X.UL "Command Typed" " "
X.UL "Command Recorded"
X.nf
X
X\fBhistory set a [expr $b+2]\fR
X\fBhistory s a b set b [expr $b+2]\fR
X\fBset c [history w 2] set c [expr $b+2]\fR
X.DE
X.VS
XHistory revision is needed because event specifiers like \fB\-1\fR
Xare only valid at a particular time: once more events have been
Xadded to the history list a different event specifier would be
Xneeded.
XHistory revision occurs even when \fBhistory\fR is invoked
Xindirectly from the current event (e.g. a user types a command
Xthat invokes a Tcl procedure that invokes \fBhistory\fR): the
Xtop-level command whose execution eventually resulted in a
X\fBhistory\fR command is replaced.
XIf you wish to invoke commands like \fBhistory words\fR without
Xhistory revision, you can use \fBhistory event\fR to save the
Xcurrent history event and then use \fBhistory change\fR to
Xrestore it later.
X.VE
X.VE
X.RE
X.TP
X\fBif \fItest \fR?\fBthen\fR? \fItrueBody \fR?\fBelse\fR? ?\fIfalseBody\fR?
XThe \fIif\fR command evaluates \fItest\fR as an expression (in the
Xsame way that \fBexpr\fR evaluates its argument). The value of the
Xexpression must be numeric; if it
Xis non-zero then \fItrueBody\fR is called by passing it to the
XTcl interpreter. Otherwise \fIfalseBody\fR is executed by passing it to
Xthe Tcl interpreter. The \fBthen\fR and \fBelse\fR arguments are optional
X``noise words'' to make the command easier to read. \fIFalseBody\fR is
Xalso optional; if it isn't specified then the command does nothing if
X\fItest\fR evaluates to zero. The return value from \fBif\fR is
Xthe value of the last command executed in \fItrueBody\fR or
X\fIfalseBody\fR, or the empty string if \fItest\fR evaluates to zero and
X\fIfalseBody\fR isn't specified.
X.TP
X\fBincr \fIvarName \fR?\fIincrement\fR?
X.VS
XIncrement the value stored in the variable whose name is \fIvarName\fR.
XThe value of the variable must be integral.
XIf \fIincrement\fR is supplied then its value (which must be an
Xinteger) is added to the value of variable \fIvarName\fR; otherwise
X1 is added to \fIvarName\fR.
XThe new value is stored as a decimal string in variable \fIvarName\fR
Xand also returned as result.
X.VE
X.TP
X\fBinfo \fIoption \fR?\fIarg arg ...\fR?
XProvide information about various internals to the Tcl interpreter.
XThe legal \fIoption\fR's (which may be abbreviated) are:
X.RS
X.TP
X\fBinfo args \fIprocname\fR
XReturns a list containing the names of the arguments to procedure
X\fIprocname\fR, in order. \fIProcname\fR must be the name of a
XTcl command procedure.
X.TP
X\fBinfo body \fIprocname\fR
XReturns the body of procedure \fIprocname\fR. \fIProcname\fR must be
Xthe name of a Tcl command procedure.
X.TP
X\fBinfo cmdcount\fR
XReturns a count of the total number of commands that have been invoked
Xin this interpreter.
X.TP
X\fBinfo commands \fR?\fIpattern\fR?
XIf \fIpattern\fR isn't specified, returns a list of names of all the
XTcl commands, including both the built-in commands written in C and
Xthe command procedures defined using the \fBproc\fR command.

XIf \fIpattern\fR is specified, only those names matching \fIpattern\fR
Xare returned. Matching is determined using the same rules as for
X\fBstring match\fR.

X.TP
X\fBinfo default \fIprocname arg varname\fR
X\fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR
Xmust be the name of an argument to that procedure. If \fIarg\fR
Xdoesn't have a default value then the command returns \fB0\fR.
XOtherwise it returns \fB1\fR and places the default value of \fIarg\fR
Xinto variable \fIvarname\fR.
X.TP
X\fBinfo exists \fIvarName\fR
XReturns \fB1\fR if the variable named \fIvarName\fR exists in the
Xcurrent context (either as a global or local variable), returns \fB0\fR
Xotherwise.
X.TP
X\fBinfo globals \fR?\fIpattern\fR?
XIf \fIpattern\fR isn't specified, returns a list of all the names
Xof currently-defined global variables.

XIf \fIpattern\fR is specified, only those names matching \fIpattern\fR
Xare returned. Matching is determined using the same rules as for
X\fBstring match\fR.

X.TP
X\fBinfo level\fR ?\fInumber\fR?
XIf \fInumber\fR is not specified, this command returns a number
Xgiving the stack level of the invoking procedure, or 0 if the
Xcommand is invoked at top-level. If \fInumber\fR is specified,
Xthen the result is a list consisting of the name and arguments for the
Xprocedure call at level \fInumber\fR on the stack. If \fInumber\fR
Xis positive then it selects a particular stack level (1 refers
Xto the top-most active procedure, 2 to the procedure it called, and
Xso on); otherwise it gives a level relative to the current level
X(0 refers to the current procedure, -1 to its caller, and so on).
XSee the \fBuplevel\fR command for more information on what stack
Xlevels mean.
X.TP
X\fBinfo library\fR
X.VS
XReturns the name of the library directory in which standard Tcl
Xscripts are stored.
XIf there is no such directory defined for the current installation
Xthen an error is generated.
XSee the \fBlibrary\fR manual entry for details of the facilities
Xprovided by the Tcl script library.
XNormally each application will have its own application-specific
Xscript library in addition to the Tcl script library; I suggest that
Xeach application set a global variable with a name like
X\fB$\fIapp\fBLibrary\fR (where \fIapp\fR is the application's name)
Xto hold the location of that application's library directory.
X.VE
X.TP
X\fBinfo locals \fR?\fIpattern\fR?
XIf \fIpattern\fR isn't specified, returns a list of all the names
Xof currently-defined local variables, including arguments to the
Xcurrent procedure, if any.
X.VS
XVariables defined with the \fBglobal\fR and \fBupvar\fR commands
Xwill not be returned.
X.VE

XIf \fIpattern\fR is specified, only those names matching \fIpattern\fR
Xare returned. Matching is determined using the same rules as for
X\fBstring match\fR.

X.TP
X\fBinfo procs \fR?\fIpattern\fR?
XIf \fIpattern\fR isn't specified, returns a list of all the
Xnames of Tcl command procedures.

XIf \fIpattern\fR is specified, only those names matching \fIpattern\fR
Xare returned. Matching is determined using the same rules as for
X\fBstring match\fR.

X.TP
X\fBinfo script\fR
X.VS
XIf a Tcl script file is currently being evaluated (i.e. there is a
Xcall to \fBTcl_EvalFile\fR active or there is an active invocation
Xof the \fBsource\fR command), then this command returns the name
Xof the innermost file being processed. Otherwise the command returns an
Xempty string.
X.VE
X.TP
X\fBinfo tclversion\fR
XReturns the version number for this version of Tcl in the form \fIx.y\fR,
Xwhere changes to \fIx\fR represent major changes with probable
Xincompatibilities and changes to \fIy\fR represent small enhancements and
Xbug fixes that retain backward compatibility.
END_OF_FILE
if test 41756 -ne `wc -c <'tcl6.1/doc/Tcl.man.2'`; then
echo shar: \"'tcl6.1/doc/Tcl.man.2'\" unpacked with wrong size!
fi
# end of 'tcl6.1/doc/Tcl.man.2'
fi
echo shar: End of archive 33 $of 33$.
cp /dev/null ark33isdone

MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 33 archives.

echo "Combining tclVar.c.1 and tclVar.c.2 to produce tclVar.c..."
cat tcl6.1/tclVar.c.1 tcl6.1/tclVar.c.2 >tcl6.1/tclVar.c
echo "Combining Tcl.man.1, Tcl.man.2 and Tcl.man.3 to produce Tcl.man..."
cat tcl6.1/doc/Tcl.man.1 tcl6.1/doc/Tcl.man.2 \
tcl6.1/doc/Tcl.man.3 >tcl6.1/doc/Tcl.man
echo "Now cd to tcl6.1, do a 'csh ./config' and a 'make'"

0 new messages